This code creates a Desktop icon


Option Explicit


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 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 Const WM_SETICON = &H80

Private Const ICON_SMALL = 0

Private Const ICON_BIG = 1


Sub setExcelIcon(Optional stFileName As String = "", Optional strIconIndex _
                                                     As Long = 0, Optional bSetBigIcon As Boolean = False, Optional bSetSmallIcon _
                                                                                                           As Boolean = True)

    Dim hIcon As Long
    Dim hwndXLApp As Long


    On Error Resume Next

    hwndXLApp = FindWindow("XLMAIN", Application.Caption)

    If hwndXLApp <> 0 Then

        Err.Clear

        If stFileName = "" Then

            strIconIndex = 8000

            hIcon = ExtractIcon(0, Application.Path & Application.PathSeparator & "Excel.exe", strIconIndex)

        ElseIf Dir(stFileName) = "" Then

            hIcon = 0

        ElseIf Err.Number <> 0 Then

            hIcon = 0

        Else

            hIcon = ExtractIcon(0, stFileName, strIconIndex)

        End If

        If bSetBigIcon Then SendMessage hwndXLApp, WM_SETICON, ICON_BIG, hIcon

        If bSetSmallIcon Then SendMessage hwndXLApp, WM_SETICON, ICON_SMALL, hIcon

    End If

End Sub

Sub Change_Icon()
    setExcelIcon "G:\Timesheets\PDF_Archive\Miscellaneous\scsobadgeicon01.ico"
End Sub

Sub Reset_Icons()
    setExcelIcon ""
End Sub