Replace Standard XL workbook icon
 

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

Replace Standard XL workbook icon
 

I've changed following:

the handle of Excel = used application.hwnd to be sure yuo get the
active session

several lines of windowstate.. to make sure the icon on the taskbar is
updated too.

all in all .. a nice puzzle :)
cheerz!

keepITcool

< email : keepitcool chello nl (with @ and .)
< homepage: http://members.chello.nl/keepitcool



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
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
'variable declarations
Dim XLMAINhWnd As Long, XLDESKhWnd As Long, EXCEL7hWnd As Long, _
TargetWindowhWnd As Long, VirtualIcon As Long, oriState 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
'CHANGED keepITcool
XLMAINhWnd = Application.hWnd
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

'Step4.
'ADDED keepITcool.. a bit dirty but it works
With Application
.ScreenUpdating = False
If .ShowWindowsInTaskbar Then
.ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar
.ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar
End If
If Not .WindowState = xlNormal Then
oriState = .WindowState: .WindowState = xlNormal: .WindowState = _
oriState
End If
With ActiveWindow
If Not .WindowState = xlNormal Then
oriState = .WindowState: .WindowState = xlNormal: .WindowState = _
oriState
End If
End With
End With

'the function has been completed succesfully
fncSetXLWindowIcon = True
'
ExitFunction:
End Function

'Examples:
Sub test1_fncAppSet()
'set Excel's main window icon
Debug.Print fncSetXLWindowIcon("C:\Icon.ico")
End Sub
Sub test2_fncAppReset()
'restore Excel's main window icon
Debug.Print fncSetXLWindowIcon
End Sub
Sub test3_fncWkbSet()
'set active workbook's window icon
Debug.Print fncSetXLWindowIcon("C:\Icon.ico", , ActiveWorkbook.Name)
End Sub
Sub test4_fncwkbReset()
'restore active workbook's window icon
Debug.Print fncSetXLWindowIcon(, , ActiveWorkbook.Name)
End Sub

'End of code




"hglamy" wrote:

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 ?


Help is greatly appreciated.

Thank you in advance.

Kind regards,

H.G. Lamy