时间戳

首页 > 解决方案 > 未答复的旧帖子：Excel 自定义图标因多个工作簿而丢失

vba - 未答复的旧帖子：Excel 自定义图标因多个工作簿而丢失

问题描述

我可以使用以下代码为 Excel 应用程序设置自定义图标。这将更改窗口的图标，以及 Windows 任务栏中显示的图标：

Public Const strIcon As String = "%SystemRoot%\system32\SHELL32.dll" ' Icon file
Public Const IconIndex As Long = 137

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As Long
Public Declare Function SendMessageA Lib "user32" (ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Public Declare Function ExtractIconA Lib "shell32.dll" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Public Const ICON_SMALL As Long = 0&
Public Const ICON_BIG As Long = 1&
Public Const WM_SETICON As Long = &H80



Sub SetupIcon()
    SetIcon strIcon, IconIndex
End Sub

Sub SetIcon(FileName As String, Optional index As Long = 0)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' SetIcon
    ' This procedure sets the icon in the upper left corner of
    ' the main Excel window. FileName is the name of the file
    ' containing the icon. It may be an .ico file, an .exe file,
    ' or a .dll file. If it is an .ico file, Index must be 0
    ' or omitted. If it is an .exe or .dll file, Index is the
    ' 0-based index to the icon resource.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    #If VBA7 And Win64 Then
        ' 64 bit Excel
        Dim HWnd As LongPtr
        Dim HIcon As LongPtr
    #Else
        ' 32 bit Excel
        Dim HWnd As Long
        Dim HIcon As Long
    #End If
    Dim n As Long
    Dim s As String
    If Dir(FileName, vbNormal) = vbNullString Then
        ' file not found, get out
        Exit Sub
    End If
    ' get the extension of the file.
    n = InStrRev(FileName, ".")
    s = LCase(Mid(FileName, n + 1))
    ' ensure we have a valid file type
    Select Case s
        Case "exe", "ico", "dll"
            ' OK
        Case Else
            ' invalid file type
            Err.Raise 5
    End Select
    HWnd = Application.HWnd
    If HWnd = 0 Then
        Exit Sub
    End If
    HIcon = ExtractIconA(0, FileName, index)
    If HIcon <> 0 Then
        SendMessageA HWnd, WM_SETICON, ICON_SMALL, HIcon
    End If
End Sub

然而，我注意到的是，如果将新工作簿添加到应用程序中，则自定义图标会丢失（至少在任务栏中） - 并且它会恢复为默认的 Excel 图标。

在网上搜索解决方案时，我发现了一个类似的问题： 打开另一个工作簿时更改 Excel 图标不起作用

自然，我通常不会发布与现有问题完全相同的新问题。然而，没有（现成的）解决方案已提供给该链接的问题。我还注意到这个问题是在 2012 年发布的，因此很可能从那时起我们的社区在专业知识和经验方面有所增长。他们很可能是现在在这里的某个人，他知道如何解决它，但根本没有看到这个问题。我希望社区能原谅这个重复的问题（把它想象成撞到旧的问题）。

有人可以为此提供解决方案吗？我的 API 知识几乎为零。谢谢。

标签： vbaexcelwinapihwnd

解决方案

当您启动 Excel 时，它会使用一个应用程序图标在此处输入图像描述。

它会一直使用它，直到您在 Excel 最初创建的工作簿之外创建任何工作簿。然后它会在任务栏上展开工作簿，您会得到两个带有工作簿图标的按钮在此处输入图像描述。

即使您关闭第二个工作簿，第一个工作簿仍然使用工作簿图标。当您关闭所有工作簿时，它将恢复为应用程序图标（您可以通过调用SetupIcon并关闭所有工作簿来检查它），但在创建任何工作簿后它会切换回工作簿图标。

您应该尝试枚举所有工作簿窗口并为它们更改图标。

我不确定这是否可以直接在 VBA 中完成，但您可以使用 winapi 函数FindWindowEx, EnumChildWindows, GetWindow.

Excel 主窗口具有类名XLMAIN。它包含XLDESK其中包含工作簿 ( EXCEL7) 和其他子项。用于Spy++检查层次结构。

此行为可能取决于任务栏设置和可用空间。如果任务栏没有爆炸按钮，它将显示应用程序图标。

检查了它，不幸的是它不起作用。它会更改工作簿窗口的图标（未最大化时），但任务栏上的图标保持不变。

这行得通，但它有点骇人听闻。我正在使用硬编码的类名MS-SDIb。这是 Excel 2007 的实现细节，可能不适用于其他版本。

'Doesn't work for me
'Public Const strIcon As String = "%SystemRoot%\system32\SHELL32.dll" ' Icon file
Public Const strIcon As String = "C:\Windows\system32\SHELL32.dll" ' Icon file

Public Const IconIndex As Long = 137

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As Long
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClassName As String, ByVal lpszCaption As String) As Long
' For 64 bit may need replacing with SetClassLongPtr
Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const GCL_HICON As Long = -14
Const GCL_HICONSM As Long = -34
Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Public Declare Function SendMessageA Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Public Declare Function ExtractIconA Lib "shell32.dll" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Public Const ICON_SMALL As Long = 0&
Public Const ICON_BIG As Long = 1&
Public Const WM_SETICON As Long = &H80


Sub SetupIcon()
    SetIcon strIcon, IconIndex
End Sub

Sub SetIcon(FileName As String, Optional index As Long = 0)
    #If VBA7 And Win64 Then
        ' 64 bit Excel
        Dim hwnd As LongPtr
        Dim DeskHWnd As LongPtr
        Dim Workbook As LongPtr
        Dim HIcon As LongPtr
    #Else
        ' 32 bit Excel
        Dim hwnd As Long
        Dim DeskHWnd As Long
        Dim Workbook As Long
        Dim HIcon As Long
    #End If
    Dim ThreadId As Long
    Dim n As Long
    Dim s As String
    If Dir(FileName, vbNormal) = vbNullString Then
        ' file not found, get out
        Exit Sub
    End If
    ' get the extension of the file.
    n = InStrRev(FileName, ".")
    s = LCase(Mid(FileName, n + 1))
    ' ensure we have a valid file type
    Select Case s
        Case "exe", "ico", "dll"
            ' OK
        Case Else
            ' invalid file type
            Err.Raise 5
    End Select
    hwnd = Application.hwnd
    If hwnd = 0 Then
        Exit Sub
    End If
    ThreadId = GetWindowThreadProcessId(hwnd, ByVal 0&)
    DeskHWnd = FindWindowEx(hwnd, 0, "XLDESK", vbNullString)
    If DeskHWnd = 0 Then
        Exit Sub
    End If

    HIcon = ExtractIconA(0, FileName, index)
    If HIcon = 0 Then
        Exit Sub
    End If

    SendMessageA hwnd, WM_SETICON, ICON_SMALL, HIcon
    SendMessageA hwnd, WM_SETICON, ICON_BIG, HIcon
    ' For 64 bit may need replacing with SetClassLongPtr
    SetClassLong hwnd, GCL_HICON, HIcon
    SetClassLong hwnd, GCL_HICONSM, HIcon

    WorkbookHWnd = FindWindowEx(DeskHWnd, 0, "EXCEL7", vbNullString)
    Do While WorkbookHWnd <> 0
        SendMessageA WorkbookHWnd, WM_SETICON, ICON_SMALL, HIcon
        SendMessageA WorkbookHWnd, WM_SETICON, ICON_BIG, HIcon

        WorkbookHWnd = FindWindowEx(DeskHWnd, WorkbookHWnd, "EXCEL7", vbNullString)
    Loop
    SetClassLong WorkbookHWnd, GCL_HICON, HIcon
    SetClassLong WorkbookHWnd, GCL_HICONSM, HIcon

    WorkbookHWnd = FindWindowEx(0, 0, "MS-SDIb", vbNullString)
    Do While WorkbookHWnd <> 0
        ' Check if WorkbookHWnd was created by same thread as Application.hwnd
        If ThreadId = GetWindowThreadProcessId(WorkbookHWnd, ByVal 0&) Then
            SendMessageA WorkbookHWnd, WM_SETICON, ICON_SMALL, HIcon
            SendMessageA WorkbookHWnd, WM_SETICON, ICON_BIG, HIcon
            SetClassLong WorkbookHWnd, GCL_HICON, HIcon
            SetClassLong WorkbookHWnd, GCL_HICONSM, HIcon
        End If

        WorkbookHWnd = FindWindowEx(0, WorkbookHWnd, "MS-SDIb", vbNullString)
    Loop
End Sub

由于使用 更改类图标，甚至适用于新工作簿SetClassLong。

BUG：每个调用都会泄漏返回的图标ExtractIconA。

推荐阅读