Hello,

after a long search, I finally found the vba code to replace the
XL-icon in a workbook (title bar top left) by a custom icon.

I do not understand it, but it works (procedures test3 and test4).

Unfortunately, only in workbooks that have not yet been saved.

Can anybody say how to make it work once a workbook
has been saved ?


'Beginning of code:

Option Explicit
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
' The ExtractIcon function retrieves the handle of an icon from the given
executable file, dynamic-link library (DLL), or icon file.
' Parameters: hInst - (Long ) Identifies the instance of the application
calling the function.
' lpszExeFileName - (String) Points to a null-terminated string specifying
the name of an executable file, DLL, or icon file.
' nIconIndex - (Long ) Specifies the index of the icon to retrieve. If this
value is 0, the function returns the handle of
' the first icon in the specified file. If this value is -1, the function
returns the total number of icons
' in the specified file.
' Return Value: If the function succeeds, the return value is the handle of
an icon. If the file specified was not an executable file, DLL, or
' icon file, the return is 1. If no icons were found in the file, the return
value is NULL.
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
Const WM_SETICON As Long = &H80

Public Function fncSetXLWindowIcon _
( _
Optional IconFile As String = vbNullString, _
Optional IconObject As IPictureDisp, _
Optional WorkbookName As String = vbNullString _
) _
As Boolean
'changes the icon of the main Excel window or the icon of a specific
workbook, to an icon contained in the
'IconFile.
'if both parameters are missing, the function restores Excel's XLMAIN window
default icon;
'if only the icon file has been specified, the function changes Excel 's
XLMAIN window icon to the new one;
'if both parameters are specified, the function changes the window icon of
the specified workbook to the new one;
'if only the WorkbookName parameter has been specified, the function
restores the window icon of the specified workbook
'returns True on success; False on failure
'
'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 = False
'
'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 handle to the workbook's 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 IconObject Is Nothing Then
If IconFile = vbNullString Then
'assume that the user asked to restore the original icon
VirtualIcon = 0
Else
'try to extract the first 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
Else
VirtualIcon = IconObject
End If
'
'Step 3. Send a Windows message to the specified window to change the Icon
'(in most cases only the second (False) message is adequate)
SendMessage TargetWindowhWnd, WM_SETICON, True, VirtualIcon
SendMessage TargetWindowhWnd, WM_SETICON, False, VirtualIcon
'
'the function has been completed succesfully
fncSetXLWindowIcon = True
'
ExitFunction:
End Function

'Examples:
Sub test1_fncSetXLWindowIcon()
'set Excel's main window icon
Debug.Print fncSetXLWindowIcon(IconFile:="C:\Icon.ico")
'Debug.Print fncSetXLWindowIcon(IconObject:=Sheet1.Image1.Pictu re)
End Sub
Sub test2_fncSetXLWindowIcon()
'restore Excel's main window icon
Debug.Print fncSetXLWindowIcon
End Sub
Sub test3_fncSetXLWindowIcon()
'set active workbook's window icon
Debug.Print fncSetXLWindowIcon(IconFile:="C:\Icon.ico", _
WorkbookName:=ActiveWorkbook.Name)
' Debug.Print fncSetXLWindowIcon(IconObject:=Sheet1.Image1.Pictu re, _
WorkbookName:=ActiveWorkbook.Name)
End Sub
Sub test4_fncSetXLWindowIcon()
'restore active workbook's window icon
Debug.Print fncSetXLWindowIcon(, _
WorkbookName:=ActiveWorkbook.Name)
End Sub

'End of code
<<<<<<<<<<<<<<<<<<<<<<<<<

Help is greatly appreciated.

Thank you in advance.

Kind regards,

H.G. Lamy