I got this on this forum quite some time ago.
HTH,
Gary Brown
'/================================================/
Option Explicit
'Thanks to Bill Manville
'"Marek Sujdak" <
[email protected]
'/================================================/
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetWindowWord Lib "user32" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Integer
Private 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
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA"
_
(ByVal hInst As Long, ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long
Private Declare Function DestroyIcon Lib "user32" _
(ByVal hIcon As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" _
Alias "SetFocus" (ByVal hwnd As Long) As Long
'
' API Constants
'
Global Const WM_SETICON = &H80
Global Const GWL_HINSTANCE = (-6)
Global Const GWL_STYLE = (-16)
Global Const WS_SYSMENU = &H80000
Public Const SM_CXICON = 11
Public Const SM_CYICON = 12
Public Const SM_CXSMICON = 49
Public Const SM_CYSMICON = 50
Const SW_SHOW = 5
'
' Various Windows Handles
'
Dim hPreviousXLMAINBigIcon As Long
Dim hPreviousXLMAINSmallIcon As Long
Dim hPreviousEXCEL9BigIcon As Long
Dim hPreviousEXCEL9SmallIcon As Long
Dim hNewIcon As Long
Dim hInstanceExcel As Integer
Dim hWndXLMAIN As Long
Dim hWndEXCEL9 As Long
'/===========================================================/
Sub SetPerceptorIcon()
Dim theIconSource As String
Dim theIconIndex As Long
Dim istat As Long
theIconSource = ThisWorkbook.Path & "\Applicat.ico"
' can be any valid windows icon source(.EXE, .DLL, .ICO)
theIconIndex = 0
' the index to the icon within the source
' If this index is 0, the ExtractIcon function
' returns the first icon in the source
istat = SetNewIcon(theIconSource, theIconIndex) ' do the deed
End Sub
'/===========================================================/
' A routine to change the standard Excel Icons
Private Function SetNewIcon(theIconSource As String, _
theIconIndex As Long) As Long
Dim l As Long
' Get handle to active window (Classname XLMAIN).
hWndXLMAIN = FindWindow("XLMAIN", Application.Caption)
l = SetFocusAPI(hWndXLMAIN)
hWndEXCEL9 = GetFocus()
' Getthe icon from the source
hNewIcon = ExtractIcon(0, theIconSource, 0)
SetNewIcon = hNewIcon ' return code from function
If hNewIcon = Null Or hNewIcon = 1 Then
' 1 means invalid icon source, 0means no icons in source
MsgBox "icon not found"
GoTo TidyUp
End If
hPreviousXLMAINBigIcon = _
SendMessage(hWndXLMAIN, WM_SETICON, 1, hNewIcon) ' Big Icon
hPreviousXLMAINSmallIcon = _
SendMessage(hWndXLMAIN, WM_SETICON, 0, hNewIcon) ' Small Icon
hPreviousEXCEL9BigIcon = _
SendMessage(hWndEXCEL9, WM_SETICON, 1, hNewIcon) ' Big Icon
hPreviousEXCEL9SmallIcon = _
SendMessage(hWndEXCEL9, WM_SETICON, 0, hNewIcon) ' Small Icon
TidyUp:
End Function
'/===========================================================/
'
' A routine to restore the standard Excel Icons
Sub restoreXLIcon()
Dim hIcon As Long
Dim lRetv As Long
hIcon = SendMessage(hWndXLMAIN, WM_SETICON, True, _
hPreviousXLMAINBigIcon) ' restore Big Icon
hIcon = SendMessage(hWndXLMAIN, WM_SETICON, False, _
hPreviousXLMAINSmallIcon) ' restore Small Icon
hIcon = SendMessage(hWndEXCEL9, WM_SETICON, True, _
hPreviousEXCEL9BigIcon) ' restore Big Icon
hIcon = SendMessage(hWndEXCEL9, WM_SETICON, False, _
hPreviousEXCEL9SmallIcon) ' restore Small Icon
lRetv = DestroyIcon(hIcon) ' I think this is necessary to free
' memory reserved in ExtractIcon
End Sub
'/===========================================================/
