Re: Icon in Symbolleisten aus Bilddatei
04.07.2002 17:30:46
Michael Scheffler
Hallo,alles irgendwo aus dem Netz und greift auf API-Funktionen zurück:
Das ist zum Ändern des Excel-Icon:
' Icon
Declare Function GetActiveWindow32 Lib "USER32" Alias _
"GetActiveWindow" () As Integer
Declare Function SendMessage32 Lib "USER32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function ExtractIcon32 Lib "SHELL32.DLL" Alias _
"ExtractIconA" (ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long
Sub ChangeXLIcon()
Dim h32NewIcon As Long
Dim h32WndXLMAIN As Long
h32NewIcon = ExtractIcon32(0, "rep.ico", 0)
h32WndXLMAIN = GetActiveWindow32()
SendMessage32 h32WndXLMAIN, &H80, 1, h32NewIcon 'Icon big
SendMessage32 h32WndXLMAIN, &H80, 0, h32NewIcon 'Icon small
End Sub
und das ist zum Laden einer Bitmap und Kopieren in einen CommandButton:
Declare Function LoadImage Lib "USER32" Alias "LoadImageA" (ByVal _
hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Declare Function CloseClipboard Lib "USER32" () As Long
Declare Function OpenClipboard Lib "USER32" (ByVal hWnd As Long) As Long
Declare Function EmptyClipboard Lib "USER32" () As Long
Declare Function SetClipboardData Lib "USER32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function IsClipboardFormatAvailable Lib "USER32" (ByVal wFormat As Long) As Long
Sub SetMenuIcon(strMenuname As String)
Dim hBitmap As Long
Dim ct As CommandBarButton
hBitmap = LoadImage(0&, ActiveWorkbook.Path & "\rep.bmp", IMAGE_BITMAP, 16, 16, LR_LOADFROMFILE)
If hBitmap = 0 Then
MsgBox "There was an error while loading icon bitmap rep.bmp"
Exit Sub
End If
'open the clipboard
OpenClipboard 0&
'Clear the clipboard
EmptyClipboard
'Put our bitmap onto the clipboard
SetClipboardData CF_BITMAP, hBitmap
'Check if there's a bitmap on the clipboard
If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then
MsgBox "There was an error while pasting the icon bitmap to the clipboard!"
End If
'Close the clipboard
CloseClipboard
Set ct = CommandBars("Repair2000").Controls(1)
ct.PasteFace
ct.style = msoButtonIcon
Set ct = Nothing
End Sub
Gruß
Micha