Changing the .ico icon of my excel file?

I would like to change the icon of my workbook to a different .ico file than the excel icon. I have already created the icon image file, and located here:

G:\Timesheets\PDF_Archive\Miscellaneous\scsobadgeicon01.ico

Is there a way to change the icon for my excel workbook without it affecting other excel workbooks unrelated to my project?

The icon on the workbook corner?

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

I've never used that code, simply found it some time ago & stored in my code library.

I've come up with this that works

'---------------------------------------------------------------------------------------
' Module    : mAddRemoveShortcut
' Author    : user
' Website   : for more examples and Excel Consulting
' Date      : 26/03/2011
' Purpose   : Add and remove desktop icon to active workbook
'---------------------------------------------------------------------------------------


Option Explicit


Sub CreateDesktopShortcut()
    Dim WSHShell As Object
    Dim MyShortcut As Object
    Dim DesktopPath As String
    Set WSHShell = CreateObject("WScript.Shell")
    DesktopPath = WSHShell.SpecialFolders("Desktop")
    Set MyShortcut = WSHShell.CreateShortcut(DesktopPath & "\" & _
                                             ThisWorkbook.Name & ".lnk")
    With MyShortcut
        .TargetPath = ThisWorkbook.FullName
        .IconLocation = "G:\Timesheets\PDF_Archive\Miscellaneous\scsobadgeicon01.ico"
        .Save
    End With
    Set WSHShell = Nothing
    MsgBox "A shortcut to " & ThisWorkbook.Name & " has been placed on your desktop.", vbInformation, "Success"
End Sub

Sub DeleteDesktopShortcut()
    Dim WSHShell As Object
    Dim MyShortcut As Object
    Dim DesktopPath As String
    Set WSHShell = CreateObject("WScript.Shell")
    DesktopPath = WSHShell.SpecialFolders("Desktop")
    On Error GoTo NotFound
    Kill (DesktopPath & "\" & ThisWorkbook.Name & ".lnk")
    MsgBox "The shortcut has been removed from your desktop.", vbInformation, "Success"
    Set WSHShell = Nothing
    Exit Sub
NotFound:
    MsgBox "A shortcut to the " & ThisWorkbook.Name & " was not found on your desktop.", vbCritical, "Aborted"
    Set WSHShell = Nothing
End Sub

This creates a shortcut of the file
E:\example.xls
In folder C:\

Sub snb()
  With CreateObject("WScript.Shell").CreateShortCut("C:\example.xls.lnk")
    .targetpath = "E:\example.xls"
    .iconlocation="G:\Timesheets\PDF_Archive\Miscellaneous\scsobadgeicon01.ico"
    .Save
  End With
End Sub

If you can't get it to work (after adaptation) in your situation please tell us:
- the location and the filename you want to make a shortcut for
- the location where the shortcut must be put.

You could try putting the icon in the same location as the workbook, then use ThisWorkBook.Path

Sub snb()
  With CreateObject("WScript.Shell").CreateShortCut("C:\Users\jmv\Desktop\FY2011 Timesheet Template.xlsb.lnk")
    .targetpath = "G:\Timesheets\FY2011\Communications\FY2011 Timesheet Template.xlsb"
    .iconlocation="G:\Timesheets\PDF_Archive\Miscellaneous\scsobadgeicon01.ico"
    .Save
  End With
End Sub

I've "borrowed" an icon, put in the same folder as the workbook & amended the code

royUK...

I am sorry for being so dense today. Is it Friday yet? I unzipped the folder and put it on my desktop. What now? Was the excel file icon supposed to mirror the .ico file? It didn't (see attached)...I am sure it is my fault. :-/

Update: Also...when refering to a file located on the computer that has spaces (such as "FY2011 Timesheet Template"), does one need to use underscores in place of the spaces?

After playing around with your guys' code a bit, I managed to get something to work (seen below). I inserted snb's code into the Workbook_BeforeClose command of the "ThisWorkbook" code. The user has to go through all of the folders to get to their timesheet only once, and then it creates the shortcut with the cusomised .ico file when the document is closed. They have to open it the hard way once on each workstation. I am satisifed with this solution.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)"
Application.DisplayStatusBar = True

  With CreateObject("WScript.Shell").CreateShortCut("C:\Users\jmv\Desktop\FY2011 Timesheet Template.lnk")
    .targetpath = "G:\Timesheets\FY2011\Communications\FY2011 Timesheet Template.xlsb"
    .iconlocation = "G:\Timesheets\PDF Archive\Miscellaneous\timesheeticon.ico"
    .Save
  End With

End Sub

Private Sub Workbook_Deactivate()
Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",True)"
Application.DisplayStatusBar = True
End Sub

Private Sub Workbook_Activate()
Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)"
Application.DisplayStatusBar = True
End Sub

Private Sub Workbook_Open()
Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)"
Application.DisplayFormulaBar = False
Worksheets("Menu").Select
Application.DisplayStatusBar = False
 
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",False)"
Application.DisplayFormulaBar = False
Application.DisplayStatusBar = False
If IsNumeric(Sh.Name) Then
Sh.ScrollArea = "A1:O30"
Else
Sh.ScrollArea = "A1:M12"
End If
End Sub