AW: Excel Fenster - Titelleiste bearbeiten
24.06.2005 00:53:36
Matthias
Hallo Chris,
in "DieseArbeitsmappe":
Private Sub Workbook_Activate()
Dim cb As CommandBar
Application.Caption = "Mein Projekt"
ActiveWindow.Caption = "Version 1"
For Each cb In Application.CommandBars
cb.Enabled = False
Next
Application.DisplayFormulaBar = False
SetXLAppIcon
End Sub
Private Sub Workbook_Deactivate()
Application.Caption = ""
Dim cb As CommandBar
For Each cb In Application.CommandBars
cb.Enabled = True
Next
Application.DisplayFormulaBar = True
ResetXLAppIcon
End Sub
und in ein normales Modul:
Option Explicit
'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 SetXLAppIcon()
'set XL's main window icon
fncSetXLWindowIcon "e:\icons\dp1.ICO"
End Sub
Sub ResetXLAppIcon()
'restore XL's main window icon
fncSetXLWindowIcon
End Sub
Sub SetXLWindowIcon()
'set active workbook's window icon
fncSetXLWindowIcon "e:\icons\32-smile.ICO", ActiveWorkbook.Name
End Sub
Sub ResetXLWindowIcon()
'restore active workbook's window icon
fncSetXLWindowIcon , ActiveWorkbook.Name
End Sub
Der Pfad zu den .ICO-Dateien muss noch angepasst werden.
Gruß Matthias