Excel 2003 toolbar with custom image

[Westman]

Hi,
Is it possible to use a custom image for excel toolbar? I mean using
external picture such as .png, .img...etc. The toolbar was created in xla
format using vba.

Thanks.

 

[Peter T]

You can certainly use your 16x16 picture for the icon property of a button,
but nothing larger than that on a commandbar.

It Excel 2007 you can use 'Gallery' for your own pictures in your
customized Ribbon.

Regards,
Peter T

 

[Westman]

Thanks for the reply.

What is the best way to do that? How to use external picture in my toolbar?

 

[Peter T]

Simplest way would be first to "Insert" the picture onto a sheet, then
CopyPicture and PasteFace. Adapt the following to your needs -

Sub test()
Dim sPic As String, sPath As String
Dim cbr As CommandBar
Dim cbt As CommandBarButton

On Error Resume Next
' delete the old bar if it exists
CommandBars("TestBar").Delete
On Error GoTo 0

sPath = "C:\Documents and Settings\Owner\My Documents\My Pictures\"

Set cbr = CommandBars.Add("TestBar", temporary:=True)
Set cbt = cbr.Controls.Add(msoControlButton)

sPic = "myPic.bmp"

If GetAndCopyPic(sPath, sPic) Then
cbt.PasteFace
Else
' what to do if failed to get the picture
MsgBox "failed to copy " & sPic
End If

cbt.OnAction = "myMacro"
cbt.Visible = True

cbr.Visible = True

End Sub

Function GetAndCopyPic(sPath As String, sPic As String) As Boolean
Dim sName As String
Dim ws As Worksheet
Dim pic As Picture

On Error GoTo errH
Set ws = ThisWorkbook.Worksheets("Sheet1")
sName = Left$(sPic, InStrRev(sPic, ".") - 1)

On Error Resume Next
Set pic = ws.Pictures(sName)
On Error GoTo errH

If pic Is Nothing Then
Set pic = ws.Pictures.Insert(sPath & sPic)
pic.Name = sName
End If

pic.CopyPicture
GetAndCopyPic = True

Exit Function

errH:
Debug.Print Err.Description
''' uncoment for testing
'stop
'resume nextion
End Function


Regards,
Peter T

 

[Westman]

Thanks, it worked.

Simplest way would be first to "Insert" the picture onto a sheet, then
CopyPicture and PasteFace. Adapt the following to your needs -

Sub test()
Dim sPic As String, sPath As String
Dim cbr As CommandBar
Dim cbt As CommandBarButton

On Error Resume Next
' delete the old bar if it exists
CommandBars("TestBar").Delete
On Error GoTo 0

sPath = "C:\Documents and Settings\Owner\My Documents\My Pictures\"

Set cbr = CommandBars.Add("TestBar", temporary:=True)
Set cbt = cbr.Controls.Add(msoControlButton)

sPic = "myPic.bmp"

If GetAndCopyPic(sPath, sPic) Then
cbt.PasteFace
Else
' what to do if failed to get the picture
MsgBox "failed to copy " & sPic
End If

cbt.OnAction = "myMacro"
cbt.Visible = True

cbr.Visible = True

End Sub

Function GetAndCopyPic(sPath As String, sPic As String) As Boolean
Dim sName As String
Dim ws As Worksheet
Dim pic As Picture

On Error GoTo errH
Set ws = ThisWorkbook.Worksheets("Sheet1")
sName = Left$(sPic, InStrRev(sPic, ".") - 1)

On Error Resume Next
Set pic = ws.Pictures(sName)
On Error GoTo errH

If pic Is Nothing Then
Set pic = ws.Pictures.Insert(sPath & sPic)
pic.Name = sName
End If

pic.CopyPicture
GetAndCopyPic = True

Exit Function

errH:
Debug.Print Err.Description
''' uncoment for testing
'stop
'resume nextion
End Function


Regards,
Peter T