Thema: Auswechseln der Excel- und Arbeitsmappen-Icons

StandardModule: basMain

Code von Stratos Malasiotis

-----------------------------------------------------------------
Win32 API Function Declarations
-----------------------------------------------------------------
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
-----------------------------------------------------------------
Win32 API Constant Declarations
-----------------------------------------------------------------
Const WM_SETICON As Long = &H80
-----------------------------------------------------------------
Custom function for changing Excel's windows icons
-----------------------------------------------------------------
Public Function fncSetXLWindowIcon _
      ( _
       Optional IconFile As String = vbNullString, _
       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
 'initialise the result of the function to false; assume failure
  fncSetXLWindowIcon = True
 '-----------------------------------------------------------------
 '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 hendle to that workbook 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 IconFile = vbNullString Then
    'assume that the user asked to restore the original icon
     VirtualIcon = 0
  Else
    'try to extract the 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
 '-----------------------------------------------------------------
 'STEP 3. Send a Windows message to the specified window to change
 '        its icon
 '-----------------------------------------------------------------
 'in most cases only the second (False) message is adequate
  SendMessage TargetWindowhWnd, WM_SETICON, True, VirtualIcon
  SendMessage TargetWindowhWnd, WM_SETICON, False, VirtualIcon
 '
 'the functio has been completed succesfully
  fncSetXLWindowIcon = True
ExitFunction:
End Function

Sub test1_fncSetXLWindowIcon()
   'set XL's main window icon
    fncSetXLWindowIcon Range("A1").Value
End Sub

Sub test2_fncSetXLWindowIcon()
   'restore XL's main window icon
    fncSetXLWindowIcon
End Sub
Sub test3_fncSetXLWindowIcon()
   'set active workbook's window icon
    fncSetXLWindowIcon Range("A1").Value, _
      ActiveWorkbook.Name
End Sub
Sub test4_fncSetXLWindowIcon()
   'restore active workbook's window icon
    fncSetXLWindowIcon , ActiveWorkbook.Name
End Sub

()

Beiträge aus dem Excel-Forum zu den Themen API und Menue