VBA程序集(第6辑)

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图标。
程序代码如下：
*******************************************
程序23
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
Declare Function GetDesktopWindow Lib "user32" () 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
Private Const WM_SETICON = &H80
Private Const ICON_BIG = 1
Private Const ICON_SMALL = 0

Sub auto_open()
ChangeIcon
End 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 = True
End Sub
 
Function 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 If
End 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 = "我的工作簿"
      ChangeApplicationIcon
End Sub
‘******下面的代码写入标准模块中******
Declare Function GetActiveWindow32 Lib "USER32" Alias "GetActiveWindow" () As Integer
Declare Function SendMessage32 Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long,ByVal wParam As Long, ByVal lParam As Long) As Long
Declare 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 Icon
End 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 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 Long
          
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () _
  As Long
 
Private Declare Function GetDesktopWindow Lib "user32.dll" () _
  As Long

Private Const GWL_STYLE         As Long = (-16)

Private Const WS_MAXIMIZEBOX    As Long = &H10000
Private Const WS_MINIMIZEBOX    As Long = &H20000
Private Const WS_SYSMENU        As Long = &H80000

Private Const HWND_TOP          As Long = 0
Private Const SWP_NOMOVE        As Long = &H2
Private Const SWP_NOSIZE        As Long = &H1
Private Const SWP_FRAMECHANGED  As Long = &H20
Private Const SWP_DRAWFRAME     As Long = &H20
Private 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 = hwnd
End Function
‘*****************************
Private Function ApphWnd() As Long
  If Val(Application.Version) >= 10 Then
    ApphWnd = Application.hwnd
  Else
    ApphWnd = FindOurWindow("XLMAIN", Application.Caption)
  End If
End 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 , , True
End Sub
‘*****************************
Public Sub RestoreWindowX()
    ActiveWorkbook.Protect , , False
End Sub
***********************************
示例文档见(过程25)移除Excel图标.xls。UploadFiles/2006-7/78705480.rar
■ 移除Excel工作簿和工作表窗口中左上角的图标以及右上角的最大化、最小化、关闭按钮并定制菜单和工具栏
最后一个程序是一个综合性的程序，它不仅移除了工作簿和工作表的图标及按钮，而且还定制了菜单和工具栏。
运行后，将出现一个自定义的工作窗口，窗口中有自定义的菜单栏和工具栏。本工作簿的后台有三个工作表，其中一个就是界面上的主工作窗口。注意，在程序运行前，应将本工作溥和图标文件62.ico放在同一文件夹中。单击“CONFIGURE”按钮将出现自定义的菜单和工具栏，界面中Excel的图标都没有了，根本看不出是Excel应用程序，并禁用右键功能。但当您单击了“RESTORE”按钮后，将恢复Excel菜单和工具栏，工作簿图标用62.ico图标代替。
程序代码如下：
******************************************
程序26
Option Private Module
Private 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 With
ErrorExit: '恢复内存
  Set wksMenuTable = Nothing
  Set cBarPop = Nothing
  Set objMenu = Nothing
  Set cBarButton = Nothing
  Set cBar = Nothing
  Exit Sub
ErrorHandle:
  MsgBox Err.Description
  Resume ErrorExit
End 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 = Nothing
End 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 With
End 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 CreateCustomMenuBar
End Sub
‘*******************************
Public Sub Auto_Close()
  Call DestroyCustomMenuBar
  Set exl = New 定制Excel窗口
  exl.Restore
  Set exl = Nothing
End 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 Long
          
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () _
  As Long
 
Private Declare Function GetDesktopWindow Lib "user32.dll" () _
  As Long

Private Const GWL_STYLE         As Long = (-16)

Private Const WS_MAXIMIZEBOX    As Long = &H10000
Private Const WS_MINIMIZEBOX    As Long = &H20000
Private Const WS_SYSMENU        As Long = &H80000

Private Const HWND_TOP          As Long = 0
Private Const SWP_NOMOVE        As Long = &H2
Private Const SWP_NOSIZE        As Long = &H1
Private Const SWP_FRAMECHANGED  As Long = &H20
Private Const SWP_DRAWFRAME     As Long = &H20
Private Const WM_SETICON        As Long = &H80

Private Const csSettingSheet    As String = "WorkspaceSettings"

Private csCaption               As String
Private csIcon                  As String
Private csStatus                As String
Private csSheet                 As String
Private cbSysMenu               As Boolean
Private cbFullScreen            As Boolean
Private cbSelect                As Boolean
‘*******************************
Public Property Let Caption(ByVal CaptionText As String)
  csCaption = CaptionText
End Property
‘*******************************
Public Property Let Icon(ByVal FileName As String)
  csIcon = FileName
End Property
‘*******************************
Public Property Let Status(ByVal StatusText As String)
  csStatus = StatusText
End Property
‘*******************************
Public Property Let Backdrop(ByVal SheetName As String)
  csSheet = SheetName
End Property
‘*******************************
Public Property Let CloseButton(ByVal HasMenu As Boolean)
  cbSysMenu = HasMenu
End Property
‘*******************************
Public Property Let FullScreen(ByVal ShowFullScreen As Boolean)
  cbFullScreen = ShowFullScreen
End Property
‘*******************************
Public Property Let NoSelect(ByVal AllowSelection As Boolean)
  cbSelect = AllowSelection
End 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 Sub
 
ErrorHandle:
  MsgBox Err.Description, 16, "Settings Error"
  Resume ErrorExit
End 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 With
 
ErrorExit:
  Set rng = Nothing
  Set wks = Nothing
  Exit Sub
 
ErrorHandle:
  MsgBox Err.Description, 16, "Settings Error"
  Resume ErrorExit
End 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 = hwnd
End Function
‘*******************************
Private Function ApphWnd() As Long
  If Val(Application.Version) >= 10 Then
    ApphWnd = Application.hwnd
  Else
    ApphWnd = FindOurWindow("XLMAIN", Application.Caption)
  End If
End 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, hIcon
End Sub

*********************************************
示例文档见(过程26)工作窗口.xls。UploadFiles/2006-7/78984492.rar

小结
通过以上示例可以看出，Excel能让我们完全定制自已的界面，通过更换其图标，甚至可以使用户根据看不出我们是在使用Excel程序。