VBA程序集(第6辑)您可能对Excel工作簿图标和工作表图标看厌倦了，您可能找到了非常漂亮的图标想取而代之。下面所收集的4个程序是对Excel工作簿和工作表窗口中的工作簿图标、工作表图标和最大化、最小化、关闭按钮的操作，它们可以实现对这些图标的更换，以及按钮的禁用等操作。程序将在下图所示的部位进行操作。Excel窗口中的左上角
Excel窗口中的右上角这四个程序都调用了Windows API函数，有的程序中还使用了类模块，可能较难理解。不过，您不必理解它们，您需要做的只是将它们在适当的时候复制/粘贴到您的模块中，或在您理解的基础上稍作调整或修改，满足您定制Excel界面的需要就行了。您可以使用以下几种方式调试或修改我们所提供的程序，当然，您必须先将程序代码复制到您工作簿中VBE编辑器上的模块中保存。1、在Excel工作簿中选择菜单“工具——宏——宏”(或按Alt+F8组合键)，弹出“宏”对话框，在其中选择您想要运行的宏名，单击“执行”按钮。2、您可以单击在工作簿中我已经为您设置好的按钮运行宏。3、您可以在工作簿中选择菜单“工具——宏——Visual Basic编辑器”(或按Alt+F11组合键)，在模块中直接运行代码，然后回到工作簿中查看结果。当然，还有一种省事的办法就是，您不必复制代码，可以将我们附在后面的文档下载后，直接打开运行。
程序分析和程序代码■ 更改Excel工作表中左上角的图标您可以将Excel工作簿中的工作表左上角的Excel工作表图标更换，改成您认为合适的图标。本示例是将Excel工作表左上角图标更换为msn图标，在运行时，必须确保本工作簿文件与msn图标在同一文件夹下。将本示例中图标文件名改为您所选图标的名字，即可在工作表左上角看到您的图标。若您下载了本示例的附件，打开后将会看到工作表左上角的图标已变成了msn.ico图标。程序代码如下：*******************************************程序23Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As LongDeclare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As LongDeclare Function GetDesktopWindow Lib "user32" () As LongDeclare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPrivate Const WM_SETICON = &H80Private Const ICON_BIG = 1Private Const ICON_SMALL = 0
Sub auto_open()ChangeIconEnd Sub
Sub ChangeIcon() Dim strIconPath As String Dim lngXLHwnd As Long Dim lngIcon As Long Application.ScreenUpdating = False Windows(ThisWorkbook.Name).WindowState = xlNormal strIconPath = ThisWorkbook.Path & "\msn.ico" lngXLHwnd = WorkbookHandle(ThisWorkbook.Name) lngIcon = ExtractIcon(0, strIconPath, 0) SendMessage lngXLHwnd, WM_SETICON, ICON_SMALL, lngIcon SendMessage lngXLHwnd, WM_SETICON, ICON_BIG, lngIcon Application.Wait (Evaluate("=now()") + (0.25) / 86400) Windows(ThisWorkbook.Name).WindowState = xlMaximized Windows(ThisWorkbook.Name).WindowState = xlNormal Windows(ThisWorkbook.Name).WindowState = xlMaximized Application.ScreenUpdating = TrueEnd SubFunction WorkbookHandle(strWBName As String) As Long Dim dWnd As Long, hWnd As Long, mWnd As Long, cWnd As Long dWnd = GetDesktopWindow hWnd = FindWindowEx(dWnd, 0&, "XLMAIN", vbNullString) mWnd = FindWindowEx(hWnd, 0&, "XLDESK", vbNullString) While mWnd <> 0 And cWnd = 0 cWnd = FindWindowEx(mWnd, 0&, "EXCEL7", strWBName) hWnd = FindWindowEx(dWnd, hWnd, "XLMAIN", vbNullString) mWnd = FindWindowEx(hWnd, 0&, "XLDESK", vbNullString) Wend If cWnd > 0 Then WorkbookHandle = cWnd End IfEnd Function
**********************************************示例文档见(过程23)更换工作表左上角的图标为msn图标.xls。
UploadFiles/2006-7/78560282.rar■ 更改Excel工作簿中左上角的图标您可以将Excel工作簿中左上角的Excel工作簿图标更换，改成您认为合适的图标，以表示与其它工作簿的区别。有很多图标可供选择，可以通过以下方式查找图标，如点击左下角开始——搜索——在文件和文件夹中输入exe，则可发现很多带.exe后缀的图标如cmd.exe……等可供使用。只要将您找到的图标名取代notepad.exe即可。本示例将工作簿左上角的图标更换为Notepad图标。若您下载了本示例的附件，打开后将会看到工作簿左上角的图标已变成了Notepad图标。程序代码如下：********************************************程序24‘******下面的代码写入ThisWorkbook模块中******Private Sub Workbook_Open() Application.Caption = "我的工作簿" ChangeApplicationIconEnd Sub‘******下面的代码写入标准模块中******Declare Function GetActiveWindow32 Lib "USER32" Alias "GetActiveWindow" () As IntegerDeclare Function SendMessage32 Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long,ByVal wParam As Long, ByVal lParam As Long) As LongDeclare Function ExtractIcon32 Lib "SHELL32.DLL" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Sub ChangeApplicationIcon() Dim Icon& ‘*****Change Icon To Suit******* Const NewIcon$ = "notepad.exe" ‘***************************** Icon = ExtractIcon32(0, NewIcon, 0) SendMessage32 GetActiveWindow32(), &H80, 1, Icon ‘< 1 = big Icon SendMessage32 GetActiveWindow32(), &H80, 0, Icon ‘< 0 = small IconEnd Sub
*********************************************示例文档见(过程24)更换工作簿左上角的图标为NotePad.xls。
UploadFiles/2006-7/78847245.rar■ 移除Excel工作簿或工作表窗口中左上角的图标以及右上角的最大化、最小化、关闭按钮本程序将移除Excel工作簿或工作表窗口中左上角的图标以及右上角的最大化、最小化、关闭按钮，下载本示例中的附件后，当您点击工作簿中的“移除”按钮时，工作簿和工作表上的图标及最大化、最小化、关闭按钮全部移除，在您点击“恢复”按钮后，将恢复上述图标和按钮。在程序中语句HasSystemMenu False 的作用是移除工作簿左上角图标和右上角最小化/最大化/关闭按钮，将参数False改为True或省略该语句将不移除；语句RemoveWindowX 的作用是移除工作表左上角图标和右上角最小化/最大化/关闭按钮，若省略该语句，将不移除； 语句HasSystemMenu True的作用是恢复工作簿左上角图标和右上角最小化/最大化/关闭按钮；语句RestoreWindowX的作用是恢复工作表左上角图标和右上角最小化/最大化/关闭按钮。您可以根据上述语句的作用，将程序适当调整，只移除其中某项图标和按钮。程序代码如下：******************************************程序25‘******声明部分******Private Declare Function SetWindowLong Lib "user32.dll" _ Alias "SetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) _ As LongPrivate Declare Function GetWindowLong Lib "user32.dll" _ Alias "GetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long) _ As Long
Private Declare Function SetWindowPos Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByVal hWndInsertAfter As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal cx As Long, _ ByVal cy As Long, _ ByVal wFlags As Long) _ As LongPrivate Declare Function FindWindowEx Lib "user32.dll" _ Alias "FindWindowExA" ( _ ByVal hWnd1 As Long, _ ByVal hWnd2 As Long, _ ByVal lpsz1 As String, _ ByVal lpsz2 As String) _ As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByRef lpdwProcessId As Long) _ As Long
Private Declare Function SendMessage Lib "user32.dll" _ Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) _ As Long
Private Declare Function ExtractIcon Lib "shell32.dll" _ Alias "ExtractIconA" ( _ ByVal hInst As Long, _ ByVal lpszExeFileName As String, _ ByVal nIconIndex As Long) _ As LongPrivate Declare Function GetCurrentProcessId Lib "kernel32.dll" () _ As LongPrivate Declare Function GetDesktopWindow Lib "user32.dll" () _ As Long
Private Const GWL_STYLE As Long = (-16)
Private Const WS_MAXIMIZEBOX As Long = &H10000Private Const WS_MINIMIZEBOX As Long = &H20000Private Const WS_SYSMENU As Long = &H80000
Private Const HWND_TOP As Long = 0Private Const SWP_NOMOVE As Long = &H2Private Const SWP_NOSIZE As Long = &H1Private Const SWP_FRAMECHANGED As Long = &H20Private Const SWP_DRAWFRAME As Long = &H20Private Const WM_SETICON As Long = &H80‘*****************************Private Function FindOurWindow(Optional ByVal sClass As String = vbNullString, _ Optional ByVal sCaption As String = vbNullString) Dim hWndDesktop As Long Dim hwnd As Long Dim hProcThis As Long Dim hProcWindow As Long hWndDesktop = GetDesktopWindow hProcThis = GetCurrentProcessId Do hwnd = FindWindowEx(hWndDesktop, hwnd, sClass, sCaption) GetWindowThreadProcessId hwnd, hProcWindow Loop Until hProcWindow = hProcThis Or hwnd = 0 FindOurWindow = hwndEnd Function‘*****************************Private Function ApphWnd() As Long If Val(Application.Version) >= 10 Then ApphWnd = Application.hwnd Else ApphWnd = FindOurWindow("XLMAIN", Application.Caption) End IfEnd Function‘*****************************Private Sub HasSystemMenu(ByVal Allow As Boolean) Dim lStyle As Long: lStyle = GetWindowLong(ApphWnd, GWL_STYLE) If Allow Then lStyle = lStyle Or WS_SYSMENU Else lStyle = lStyle And Not WS_SYSMENU End If Call SetWindowLong(ApphWnd, GWL_STYLE, lStyle) Call SetWindowPos(ApphWnd, HWND_TOP, 0, 0, 0, 0, _ SWP_NOMOVE Or SWP_NOSIZE Or SWP_DRAWFRAME)End Sub‘*****************************Public Sub RemoveX() HasSystemMenu False ‘移除工作簿左上角图标和右上角最小化/最大化/关闭按钮 RemoveWindowX ‘移除工作表左上角图标和右上角最小化/最大化/关闭按钮End Sub‘*****************************Public Sub RestoreX() HasSystemMenu True ‘恢复工作簿左上角图标和右上角最小化/最大化/关闭按钮 RestoreWindowX ‘恢复工作表左上角图标和右上角最小化/最大化/关闭按钮End Sub‘*****************************Public Sub RemoveWindowX() ActiveWorkbook.Protect , , TrueEnd Sub‘*****************************Public Sub RestoreWindowX() ActiveWorkbook.Protect , , FalseEnd Sub***********************************示例文档见(过程25)移除Excel图标.xls。UploadFiles/2006-7/78705480.rar■ 移除Excel工作簿和工作表窗口中左上角的图标以及右上角的最大化、最小化、关闭按钮并定制菜单和工具栏最后一个程序是一个综合性的程序，它不仅移除了工作簿和工作表的图标及按钮，而且还定制了菜单和工具栏。运行后，将出现一个自定义的工作窗口，窗口中有自定义的菜单栏和工具栏。本工作簿的后台有三个工作表，其中一个就是界面上的主工作窗口。注意，在程序运行前，应将本工作溥和图标文件62.ico放在同一文件夹中。单击“CONFIGURE”按钮将出现自定义的菜单和工具栏，界面中Excel的图标都没有了，根本看不出是Excel应用程序，并禁用右键功能。但当您单击了“RESTORE”按钮后，将恢复Excel菜单和工具栏，工作簿图标用62.ico图标代替。程序代码如下：******************************************程序26Option Private ModulePrivate Const mszMenuSheetName As String = "CustomMenuBar" ‘工作表名‘*******************************Public Sub CreateCustomMenuBar() Dim cBar As CommandBar Dim cBarPop As CommandBarPopup Dim cBarButton As CommandBarButton
‘禁止屏幕刷新 With Application .ScreenUpdating = False
‘定义包含菜单数据的工作表 On Error GoTo ErrorHandle Dim wksMenuTable As Worksheet Set wksMenuTable = ThisWorkbook.Sheets(mszMenuSheetName) ‘工作表菜单名 Dim szMenuName As String szMenuName = wksMenuTable.Cells(1, 1).Value ‘从菜单中移除任何自定义菜单 Call DestroyCustomMenuBar ‘添加自定义菜单 Set cBar = .CommandBars.Add(szMenuName, , True, True) Dim lRow As Long Dim objMenu As Object Dim lLevel As Long Dim lNextLevel As Long Dim vPosOrSub As Variant Dim szCaption As String Dim bGroup As Boolean Dim lFaceId As Long Dim szShortCutText As String lRow = 3 ‘初始化开始行 ‘使用工作表中的数据添加菜单,菜单项目和子菜单 Do Until IsEmpty(wksMenuTable.Cells(lRow, 1)) With wksMenuTable lLevel = CLng(.Cells(lRow, 1)) szCaption = CStr(.Cells(lRow, 2)) szShortCutText = CStr(.Cells(lRow, 3)) vPosOrSub = .Cells(lRow, 4) bGroup = CBool(.Cells(lRow, 5)) lFaceId = CLng(.Cells(lRow, 6)) lNextLevel = CLng(.Cells(lRow + 1, 1)) End With Select Case lLevel Case 1 ‘ 菜单 Set cBarPop = Application.CommandBars(szMenuName). _ Controls.Add(msoControlPopup, , , CLng(vPosOrSub), True) cBarPop.Caption = szCaption Case 2 ‘ 菜单项 On Error Resume Next If lNextLevel = 3 Then Set objMenu = cBarPop.Controls.Add(msoControlPopup, , , , True) Else Set objMenu = cBarPop.Controls.Add(msoControlButton, , , , True) objMenu.OnAction = vPosOrSub End If objMenu.Caption = szCaption & Space(4) objMenu.ShortcutText = szShortCutText If lFaceId <> 0 Then objMenu.FaceId = CLng(lFaceId) If bGroup Then objMenu.BeginGroup = True Case 3 ‘ 子菜单 Set cBarButton = objMenu.Controls.Add(msoControlButton) cBarButton.Caption = szCaption & Space(4) cBarButton.OnAction = CStr(vPosOrSub) If lFaceId <> 0 Then cBarButton.FaceId = lFaceId If bGroup Then cBarButton.BeginGroup = True End Select lRow = lRow + 1 Loop ‘使自定义的菜单可见并不能移除 With cBar .Visible = True .Protection = msoBarNoChangeDock End With ‘移除 "AskAQuestion" 下拉表(指定版本) If Val(.Version) >= 10 Then Dim objCBarTemp As Object Set objCBarTemp = .CommandBars objCBarTemp.DisableAskAQuestionDropdown = True End If ‘缺省右击菜单列表 .CommandBars("Toolbar List").Enabled = False .ScreenUpdating = True End WithErrorExit: ‘恢复内存 Set wksMenuTable = Nothing Set cBarPop = Nothing Set objMenu = Nothing Set cBarButton = Nothing Set cBar = Nothing Exit SubErrorHandle: MsgBox Err.Description Resume ErrorExitEnd Sub‘*******************************Public Sub DestroyCustomMenuBar() ‘删除自定义工具栏 Dim wksMenuTable As Worksheet Set wksMenuTable = ThisWorkbook.Sheets(mszMenuSheetName) Dim szMenuName As String szMenuName = wksMenuTable.Cells(1, 1).Value Call KillCustomMenu(szMenuName) Set wksMenuTable = NothingEnd Sub‘*******************************Private Sub KillCustomMenu(ByVal szMenuName As String) On Error Resume Next With Application .ScreenUpdating = False ‘删除指定的菜单 Dim cb As CommandBar For Each cb In .CommandBars If cb.Name = szMenuName Then cb.Delete Next cb ‘恢复右击菜单列表 .CommandBars("Toolbar List").Enabled = True ‘恢复 "AskAQuestion" 下拉列表 (指定版本) If Val(.Version) >= 10 Then Dim objCBarTemp As Object Set objCBarTemp = .CommandBars objCBarTemp.DisableAskAQuestionDropdown = False End If .ScreenUpdating = True End WithEnd Sub‘*******************************Private Sub TestCusMenu() ‘测试命令 MsgBox "Called from custom worksheet menubar"End Sub
‘*****插入新模块并在前面声明************Dim exl As 定制Excel窗口‘*******************************Public Sub Auto_Open() Set exl = New 定制Excel窗口 With exl .Caption = "New Application" .CloseButton = False .Icon = ThisWorkbook.Path & "\62.ico" .Backdrop = "Main" .NoSelect = True .Status = "Status is Ready to Go" .Configure End With Set exl = Nothing Call CreateCustomMenuBarEnd Sub‘*******************************Public Sub Auto_Close() Call DestroyCustomMenuBar Set exl = New 定制Excel窗口 exl.Restore Set exl = NothingEnd Sub
‘******插入类模块*************************Private Declare Function SetWindowLong Lib "user32.dll" _ Alias "SetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) _ As Long
Private Declare Function GetWindowLong Lib "user32.dll" _ Alias "GetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long) _ As Long
Private Declare Function SetWindowPos Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByVal hWndInsertAfter As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal cx As Long, _ ByVal cy As Long, _ ByVal wFlags As Long) _ As Long
Private Declare Function FindWindowEx Lib "user32.dll" _ Alias "FindWindowExA" ( _ ByVal hWnd1 As Long, _ ByVal hWnd2 As Long, _ ByVal lpsz1 As String, _ ByVal lpsz2 As String) _ As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByRef lpdwProcessId As Long) _ As Long
Private Declare Function SendMessage Lib "user32.dll" _ Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) _ As Long
Private Declare Function ExtractIcon Lib "shell32.dll" _ Alias "ExtractIconA" ( _ ByVal hInst As Long, _ ByVal lpszExeFileName As String, _ ByVal nIconIndex As Long) _ As LongPrivate Declare Function GetCurrentProcessId Lib "kernel32.dll" () _ As LongPrivate Declare Function GetDesktopWindow Lib "user32.dll" () _ As Long
Private Const GWL_STYLE As Long = (-16)
Private Const WS_MAXIMIZEBOX As Long = &H10000Private Const WS_MINIMIZEBOX As Long = &H20000Private Const WS_SYSMENU As Long = &H80000
Private Const HWND_TOP As Long = 0Private Const SWP_NOMOVE As Long = &H2Private Const SWP_NOSIZE As Long = &H1Private Const SWP_FRAMECHANGED As Long = &H20Private Const SWP_DRAWFRAME As Long = &H20Private Const WM_SETICON As Long = &H80
Private Const csSettingSheet As String = "WorkspaceSettings"
Private csCaption As StringPrivate csIcon As StringPrivate csStatus As StringPrivate csSheet As StringPrivate cbSysMenu As BooleanPrivate cbFullScreen As BooleanPrivate cbSelect As Boolean‘*******************************Public Property Let Caption(ByVal CaptionText As String) csCaption = CaptionTextEnd Property‘*******************************Public Property Let Icon(ByVal FileName As String) csIcon = FileNameEnd Property‘*******************************Public Property Let Status(ByVal StatusText As String) csStatus = StatusTextEnd Property‘*******************************Public Property Let Backdrop(ByVal SheetName As String) csSheet = SheetNameEnd Property‘*******************************Public Property Let CloseButton(ByVal HasMenu As Boolean) cbSysMenu = HasMenuEnd Property‘*******************************Public Property Let FullScreen(ByVal ShowFullScreen As Boolean) cbFullScreen = ShowFullScreenEnd Property‘*******************************Public Property Let NoSelect(ByVal AllowSelection As Boolean) cbSelect = AllowSelectionEnd Property‘*******************************Public Sub Configure(Optional ByVal DisplayScrollBars As Boolean = False, _ Optional ByVal DisplayFormulaBar As Boolean = False, _ Optional ByVal WindowsInTaskbar As Boolean = False, _ Optional ByVal DisplayStatusBar As Boolean = True) Dim wks As Excel.Worksheet Dim wksMain As Excel.Worksheet Dim rng As Excel.Range Dim cbr As CommandBar On Error Resume Next Set wks = Sheets(csSettingSheet) If Err.Number <> 0 Then Set wks = ThisWorkbook.Sheets.Add wks.Name = csSettingSheet Err.Clear End If If Len(csSheet) > 0 Then Set wksMain = Sheets(csSheet) With wksMain .Select If cbSelect Then .EnableSelection = xlNoSelection .ScrollArea = "A1" .Protect , , , , True End With End If On Error GoTo ErrorHandle With wks .UsedRange.Clear Set rng = .Range("A2:F2") For Each cbr In ThisWorkbook.Application.CommandBars If cbr.Visible Then rng(1) = cbr.Name rng(2) = cbr.Top rng(3) = cbr.Left rng(4) = cbr.Height rng(5) = cbr.Width rng(6) = cbr.Position Set rng = rng.Offset(1) End If cbr.Enabled = False Next cbr .Range("C1").Value = csSheet .Range("A1") = rng.Row – 1 Set rng = rng(1) Set rng = rng.Resize(10) End With With Application .DisplayFullScreen = cbFullScreen rng(7) = .DisplayFormulaBar .DisplayFormulaBar = DisplayFormulaBar rng(7).Offset(, 1).Value = "ShowFormulaBar" rng(8) = .DisplayStatusBar .DisplayStatusBar = DisplayStatusBar rng(8).Offset(, 1).Value = "ShowStatusBar" If Val(.Version) >= 9 Then rng(9) = .ShowWindowsInTaskbar .ShowWindowsInTaskbar = WindowsInTaskbar rng(9).Offset(, 1).Value = "ShowWindowsInTaskbar" End If rng(10) = .DisplayScrollBars .DisplayScrollBars = DisplayScrollBars rng(10).Offset(, 1).Value = "ShowScrollBars" .Caption = csCaption .StatusBar = csStatus .WindowState = xlMaximized .ActiveWindow.Caption = "" .ThisWorkbook.Protect , , True .CellDragAndDrop = False .CutCopyMode = False End With If Len(csIcon) > 0 Then SetIcon ApphWnd, csIcon With ActiveWindow .DisplayGridlines = False .DisplayHeadings = False .DisplayWorkbookTabs = False .WindowState = xlMaximized rng(11) = CStr(cbSysMenu) HasSystemMenu cbSysMenu rng(11).Offset(, 1).Value = "HasSystemMenu" End With rng(12) = CStr(cbFullScreen) rng(12).Offset(, 1).Value = "DisplayFullScreen" wks.Range("B1").Value = "OK"ErrorExit: Set rng = Nothing Set wksMain = Nothing Set wks = Nothing Exit SubErrorHandle: MsgBox Err.Description, 16, "Settings Error" Resume ErrorExitEnd Sub‘*******************************Public Sub Restore() Dim wks As Excel.Worksheet Dim rng As Excel.Range Dim cbr As CommandBar If Not Sheets(csSettingSheet).Range("B1").Value = "OK" Then Exit Sub HasSystemMenu True Application.DisplayFullScreen = False
On Error GoTo ErrorHandle Set wks = Sheets(csSettingSheet) With wks If Len(.Range("C1").Value) > 0 Then With Sheets(.Range("C1").Value) .EnableSelection = xlNoRestrictions .ScrollArea = "" End With End If Set rng = .Range("A2:F2") For Each cbr In ThisWorkbook.Application.CommandBars cbr.Enabled = True Next cbr Do On Error Resume Next Set cbr = ThisWorkbook.Application.CommandBars(rng(1).Value) cbr.Top = rng(2) cbr.Left = rng(3) cbr.Height = rng(4) cbr.Width = rng(5) cbr.Position = rng(6) cbr.Enabled = True Set rng = rng.Offset(1) If rng.Row > .Range("A1") Then Exit Do Loop End With Set rng = rng(1) Set rng = rng.Resize(10) With ActiveWindow .Caption = False End With
With Application .ThisWorkbook.Protect , , False .CellDragAndDrop = True .Caption = "" .StatusBar = False .DisplayFormulaBar = rng(7) .DisplayStatusBar = rng(8) If Val(.Version) >= 9 Then .ShowWindowsInTaskbar = rng(9) .DisplayScrollBars = rng(10) .DisplayAlerts = False End WithErrorExit: Set rng = Nothing Set wks = Nothing Exit SubErrorHandle: MsgBox Err.Description, 16, "Settings Error" Resume ErrorExitEnd Sub‘*******************************Private Sub HasSystemMenu(ByVal Allow As Boolean) Dim lStyle As Long: lStyle = GetWindowLong(ApphWnd, GWL_STYLE) If Allow Then lStyle = lStyle Or WS_SYSMENU Else lStyle = lStyle And Not WS_SYSMENU End If Call SetWindowLong(ApphWnd, GWL_STYLE, lStyle) Call SetWindowPos(ApphWnd, HWND_TOP, 0, 0, 0, 0, _ SWP_NOMOVE Or SWP_NOSIZE Or SWP_DRAWFRAME)End Sub‘*******************************Private Function FindOurWindow(Optional ByVal sClass As String = vbNullString, _ Optional ByVal sCaption As String = vbNullString) Dim hWndDesktop As Long Dim hwnd As Long Dim hProcThis As Long Dim hProcWindow As Long hWndDesktop = GetDesktopWindow hProcThis = GetCurrentProcessId Do hwnd = FindWindowEx(hWndDesktop, hwnd, sClass, sCaption) GetWindowThreadProcessId hwnd, hProcWindow Loop Until hProcWindow = hProcThis Or hwnd = 0 FindOurWindow = hwndEnd Function‘*******************************Private Function ApphWnd() As Long If Val(Application.Version) >= 10 Then ApphWnd = Application.hwnd Else ApphWnd = FindOurWindow("XLMAIN", Application.Caption) End IfEnd Function‘*******************************Private Sub SetIcon(ByVal hwnd As Long, ByVal sIcon As String) Dim hIcon As Long: hIcon = ExtractIcon(0, sIcon, 0) SendMessage hwnd, WM_SETICON, True, hIcon SendMessage hwnd, WM_SETICON, False, hIconEnd Sub
*********************************************示例文档见(过程26)工作窗口.xls。UploadFiles/2006-7/78984492.rar
小结通过以上示例可以看出，Excel能让我们完全定制自已的界面，通过更换其图标，甚至可以使用户根据看不出我们是在使用Excel程序。
http://blog.excelhome.net/user1/fanjy/534.html
感受不同地域不一样的节奏与表象。
