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
|