Icon in Titelleiste aus eingebettetem Objekt

Function Declarations
Declare 

Function FindWindow _
Lib "user32" _
Alias "FindWindowA" _
( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) _
As Long
Declare 

Function FindWindowEx _
Lib "user32" _
Alias "FindWindowExA" _
( _
ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String _
) _
As Long
Declare 

Function ExtractIcon _
Lib "shell32.dll" _
Alias "ExtractIconA" _
( _
ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long _
) _
As Long
Declare 

Function SendMessage _
Lib "user32" _
Alias "SendMessageA" _
( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Integer, _
ByVal lparam As Long _
) _
As Long
'Win32 API Constant Declarations
Const WM_SETICON As Long = &H80
'Custom 

Function for changing Excel's windows icons
Public 

Function fncSetXLWindowIcon _
( _
Optional IconFile As String = vbNullString, _
Optional WorkbookName As String = vbNullString _
) _
As Boolean
'Variable Declarations
Dim XLMAINhWnd  As Long, XLDESKhWnd       As Long, _
EXCEL7hWnd  As Long, TargetWindowhWnd As Long, _
VirtualIcon As Long
'initialise the result of the 

Function to false; assume failure
fncSetXLWindowIcon = True
'STEP 1. Identify the target window
'get the caption from the first window of the specified workbook; if any
On Error Resume Next
If CBool(Len((Workbooks(WorkbookName).Name))) Then
WorkbookName = Workbooks(WorkbookName).Windows(1).Caption
End If
On Error GoTo ExitFunction
'if a caption has been extracted get a hendle to that workbook window;
'else get a handle to Excel's main window
If Not WorkbookName = vbNullString Then
XLMAINhWnd = FindWindow("XLMAIN", Application.Caption)
XLDESKhWnd = FindWindowEx(XLMAINhWnd, 0, "XLDESK", vbNullString)
TargetWindowhWnd = FindWindowEx(XLDESKhWnd, 0, "EXCEL7", WorkbookName)
Else
XLMAINhWnd = FindWindow("XLMAIN", Application.Caption)
TargetWindowhWnd = XLMAINhWnd
End If
'if  we couldn't get a handle, exit the function
If TargetWindowhWnd = 0 Then Exit Function
'STEP 2. Extract the icon from the respective file
If IconFile = vbNullString Then
'assume that the user asked to restore the original icon
VirtualIcon = 0
Else
'try to extract the icon from the specified file
VirtualIcon = ExtractIcon(0, IconFile, 0)
'If the file could not be found (1), or if the no icon could be
'found in the file (0), exit the function
If VirtualIcon <= 1 Then Exit Function
End If
'STEP 3. Send a Windows message to the specified window to change
'        its icon
'in most cases only the second (False) message is adequate
SendMessage TargetWindowhWnd, WM_SETICON, True, VirtualIcon
SendMessage TargetWindowhWnd, WM_SETICON, False, VirtualIcon
'the functio has been completed succesfully
fncSetXLWindowIcon = True
ExitFunction:
End Function



Sub SetXLAppIcon()
'set XL's main window icon
fncSetXLWindowIcon "c:\Eigene Dateien\nichtexcel.ico"
End Sub



Sub ResetXLAppIcon()
'restore XL's main window icon
fncSetXLWindowIcon
End Sub



Sub SetXLWindowIcon()
'set active workbook's window icon
fncSetXLWindowIcon "c:\Eigene Dateien\nichtexcel.ico", ActiveWorkbook.Name
End Sub



Sub ResetXLWindowIcon()
'restore active workbook's window icon
fncSetXLWindowIcon , ActiveWorkbook.Name
End Sub