[分享]VBA程序集(第6辑)

fanjy

VBA程序集
(第6辑)
您可能对Excel工作簿图标和工作表图标看厌倦了，您可能找到了非常漂亮的图标想取而代之。下面所收集的4个程序是对Excel工作簿和工作表窗口中的工作簿图标、工作表图标和最大化、最小化、关闭按钮的操作，它们可以实现对这些图标的更换，以及按钮的禁用等操作。程序将在下图所示的部位进行操作。
  qz5L5zwr.rar (10.03 KB, 下载次数: 695)

2006-7-8 09:03 上传

点击文件名下载附件
[分享]VBA程序集(第6辑)

fanjy

■ 移除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

fanjy

(接上面的程序)

‘*******************************
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。

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

By fanjy in 2006-7-8

plxmm

多谢分享，越来越有深度了。

plxmm

另外建议：fanjy朋友

你的每一集帖子的标题给出该贴的简要内容，这样看到标题，就知道该贴内容的意思了。

fanjy

plxmm，谢谢您的建议和鼓励！

但标题的字数有限制，无法写出更多的内容啊。

不过，以后我会尽可能写出简要内容的。

opiona

支持一下

建议楼主能够添加注释

lotustower

QUOTE:

以下是引用fanjy在2006-7-8 9:25:03的发言：

不过，以后我会尽可能写出简要内容的。

感覺可能是抄本 !

fanjy

QUOTE:

以下是引用fanjy在2006-7-8 9:25:03的发言：

不过，以后我会尽可能写出简要内容的。

感覺可能是抄本 !

您好！先声明这些程序都不是我自已编写的。我的程序集中的所有程序都是自已在学习VBA的过程中收集整理的并自行归纳的，有些是引用所学的源程序，有些就自已的理解作了修改。但程序集中的所有程序的说明都是就自已的理解所写的，譬如注释部分和功能说明部分，以及文字部分。我的目的是提高自已的VBA水平，同时也帮助大家提高。

[此贴子已经被作者于2006-7-8 11:55:09编辑过]

ＺＨＹＺ

fanjy做的很好,

任何人基本上是学习书本上的,借鉴学习别人的代码,吸收理解不断的提高,

任何人不可能全能通,fanjy值得鼓励.

[此贴子已经被作者于2006-7-8 13:26:14编辑过]