View Single Post
  #6   Report Post  
Posted to microsoft.public.excel.programming
vbaexperimenter vbaexperimenter is offline
external usenet poster
 
Posts: 13
Default Need help w using custom image for custom toolbar in Excel 200

Dave,
I essentially want a toolbar where the buttons are labled with the image
the macro will insert into the worksheet. I also need it as an addin so it
can be added to other computers/users. I inserted all the pictures to my
file tickmarks.xlam. I then copied and pasted your code into the module. It
keeps erroring out on the line:

PictWks.Pictures(PictNames(iCtr)).Copy

Here is the code again with your changes and the name of the sheet and
pictures

Option Explicit
Public Const ToolBarName As String = "MyToolbarName"
Sub Auto_Open()
Call CreateMenubar
End Sub
Sub Auto_Close()
Call RemoveMenubar
End Sub
Sub RemoveMenubar()
On Error Resume Next
Application.CommandBars(ToolBarName).Delete
On Error GoTo 0
End Sub
Sub CreateMenubar()

Dim iCtr As Long

Dim MacNames As Variant
Dim CapNames As Variant
Dim TipText As Variant
Dim PictNames As Variant
Dim PictWks As Worksheet

Call RemoveMenubar

MacNames = Array("Prior_Year", _
"Recalculated")

CapNames = Array("Prior_Year", _
"Recalculated")

TipText = Array("Prior_Year", _
"Recalculated")

PictNames = Array("Prior_Year", "Recalculated")

Set PictWks = ThisWorkbook.Worksheets("Pictures")

With Application.CommandBars.Add
..Name = ToolBarName
..Left = 200
..Top = 200
..Protection = msoBarNoProtection
..Visible = True
..Position = msoBarFloating

For iCtr = LBound(MacNames) To UBound(MacNames)
PictWks.Pictures(PictNames(iCtr)).Copy
With .Controls.Add(Type:=msoControlButton)
..OnAction = "'" & ThisWorkbook.Name & "'!" & MacNames(iCtr)
..Caption = CapNames(iCtr)
..Style = msoButtonIconAndCaption
..PasteFace
..TooltipText = TipText(iCtr)
End With
Next iCtr

End With
End Sub

'===========================================
Sub Prior_Year()
InsertPicture "D:\Program Files\Microsoft
Office\Office12\Tickmarks\Prior_Year.bmp", ActiveCell, True, True
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) < "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
..Top = t
..Left = l
End With
Set p = Nothing

End Sub

'===========================================
Sub Recalculated()
InsertPicture2 "D:\Program Files\Microsoft
Office\Office12\Tickmarks\Recalculated.bmp", ActiveCell, True, True
End Sub

Sub InsertPicture2(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) < "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
..Top = t
..Left = l
End With
Set p = Nothing

End Sub