VBA常用代码解析（第二十三讲）

089 创建自定义工具栏

为了方便用户操作，在Excel原有的的工具栏上，还可以创建自定义的工具栏，如下面的代码所示。

Sub NowToolbar()

Dimarr As Variant

Dimid As Variant

Dimi As Integer

DimToolbar As CommandBar

On ErrorResume Next

Application.CommandBars('MyToolbar').Delete

arr= Array('会计凭证'，'会计账簿'，'会计报表'，'凭证打印'，'账簿打印'，'报表打印')

id =Array(9893，284，9590，9614，707，986)

SetToolbar = Application.CommandBars.Add('MyToolbar'，msoBarTop)

With Toolbar

.Protection = msoBarNoResize

.Visible = True

For i = 0 To 5

With .Controls.Add(Type:=msoControlButton)

.Caption = arr(i)

.FaceId = id(i)

.BeginGroup = True

.Style = msoButtonIconAndCaptionBelow

End With

Next

End With

SetToolbar = Nothing

End Sub

代码解析：

NowToolbar过程使用Add方法在Excel窗口中创建自定义工具栏。应用于CommandBars对象的Add方法请参阅▲83 。

第10行代码，使用Add方法在菜单栏上创建名称为“MyToolbar”的命令栏，创建时设置新命令栏的Position参数为msoBarTop，使新命令栏位于应用程序窗口的顶部。如果将Position参数设置成msoBarFloating，新命令栏为浮动工具栏。

关于Position参数的MsoBarPosition常数请参阅▲83。

第12行代码，设置“MyToolbar”命令栏的Protection属性为msoBarNoResize。应用于CommandBar对象的Protection属性指定命令栏的保护类型，可以为表格所列的MsoBarProtection常数之一。

第14行到第21代码，使用Add方法在新命令栏中添加按钮控件，设置按钮控件的各项属性。其中第19行代码，设置按钮控件的Style属性为msoButtonIconAndCaptionBelow，使工具栏按钮显示时包含图标和标题，且标题位于图标之下。

应用于CommandBar对象的Style属性返回或设置工具栏按钮的显示方式，可以为表格所列的MsoButtonStyle常数之一。运行NowToolbar过程，将在Excel窗口的顶部创建一个自定义的工具栏。

▲090 自定义工具栏按钮图标

在创建自定义的工具栏时，除了可以为工具栏按钮添加Excel内置的图标外，还能为工具栏按钮添加自定义的图标，如下面的代码所示。

Sub AddCustomButton()

DimxBar As CommandBar

DimxButton As CommandBarButton

On ErrorResume Next

Application.CommandBars('CustomBar').Delete

SetxBar = CommandBars.Add('CustomBar'，msoBarTop)

SetxButton = xBar.Controls.Add(msoControlButton)

WithxButton

.Picture = LoadPicture(ThisWorkbook.Path& '\P.BMP')

.Mask = LoadPicture(ThisWorkbook.Path &'\M.BMP')

.TooltipText = 'Excel Home 论坛'

EndWith

xBar.Visible= True

SetxBar = Nothing

SetxButton = Nothing

End Sub

代码解析：

AddCustomButton过程创建自定义工具栏，并设置工具栏的按钮自定义图标。

第6、7行代码，使用Add方法在Excel窗口中添加自定义工具栏和按钮。请参阅▲89 。

第9行代码，设置工具栏按钮的Picture属性为同一目录中的p.bmp图片。

应用于CommandBarButton 对象的Picture属性返回一个IPictureDisp对象，表示 CommandBarButton对象的图像，语法如下：

expression.Picture

参数是必需的，返回一个CommandBarButton对象。

指定对象的Picture属性就能设置对象的图像。

第10行代码，设置工具栏按钮的Mask属性为同一目录中的m.bmp图片。

为了使工具栏按钮图标透明显示，在指定对象的Picture属性后，还需要指定对象的Mask属性。

应用于CommandBarButton 对象的Mask属性返回表示CommandBarButton对象的屏蔽图像的IPictureDisp对象，语法如下：

expression.Mask

参数是必需的，返回一个CommandBarButton对象。

屏蔽图像决定按钮图像透明的部分。在创建作为屏蔽图像使用的图像时，所有要透明的区域应该为白色，所有要显示的区域应该为黑色。

第11行代码，设置按钮的“屏幕提示”为“ExcelHome论坛”。

运行AddCustomButton过程，创建自定义工具栏，并设置工具栏按钮的图标。

▲091 自定义工作簿图标

Excel标题栏的图标是默认的，而借助API函数可以自定义工作簿标题栏图标，如下面的代码所示。

Private Declare Function FindWindow Lib'user32' Alias 'FindWindowA' (ByVal lpClassName As String，ByVal lpWindowName As String) As Long

Private Declare Function DrawMenuBar Lib'user32' (ByVal hWnd As Long) As Long

Private Declare Function SetFocus Lib 'user32'(ByVal hWnd As Long) As Long

Private Declare Function SendMessage Lib'user32' Alias 'SendMessageA' (ByVal hWnd As Long，ByVal wMsg As Long，ByVal wParamAs Integer，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 Const WM_SETICON = &H80

Private Sub Workbook_Open()

DimIStyle As Long

DimhIcon As Long

DimhWndForm As Long

hWndForm= FindWindow(vbNullString，Application.Caption)

hIcon= ExtractIcon(0，ActiveWorkbook.Path & '\p.bmp'，0)

SendMessagehWndForm，WM_SETICON，True，hIcon

SendMessagehWndForm，WM_SETICON，False，hIcon

End Sub

代码解析：

工作簿打开后使用API函数自定义工作簿标题栏的图标。

第1行到第6行代码，API函数声明。

第7行到第15行代码，工作簿的Open事件过程，把工作簿标题栏默认的图标更改为同一文件夹下的p.bmp图片。工作簿打开后标题栏。

▲092 移除工作表的最小最大化和关闭按钮

如果不希望工作表的最小、最大化和关闭按钮出现在菜单栏中，可以使用以下代码去除：

ActiveWorkbook.Protect，，True

代码解析：

使用Protect方法对工作簿进行保护。Protect方法应用于Workbook对象的时保护工作簿使其不至被修改，语法如下：

expression.Protect(Password，Structure，Windows)

参数expression是必需的，该表达式返回一个Workbook对象。

参数Password是可选的，为工作表或工作簿指定区分大小写的密码。

参数Structure是可选的，如果为True，则保护工作簿结构(工作表的相对位置)。默认值为False。

参数Windows是可选的，如果为True，则保护工作簿窗口。

恢复工作表的最大、最小化和关闭按钮的代码如下：

ActiveWorkbook.Protect，，False

在本例中将Windows参数设置为True，使工作簿窗口受到保护，工作表的最小、最大化和关闭按钮及图标不出现在菜单栏中。

▲093 在工具栏上添加下拉列表框

如果需要在工具栏中添加类似“字体”这样的下拉列表控制框控件，那么可以使用下面的代码。

Sub AddDropdown()

DimmyDropdown As Object

DimmyCap As Variant

Dimi As Integer

myCap= Array('基础应用'，'VBA程序开发'，'函数与公式')

CallDeleteButton

SetmyDropdown = Application.CommandBars('Formatting').Controls _

.Add(Type:=msoControlDropdown，Before:=1)

WithmyDropdown

.Caption = '请选择版块'

.OnAction = 'myOnA'

.Style = msoComboNormal

For i = 0 To UBound(myCap)

.AddItem myCap(i)

Next

.ListIndex = 1

EndWith

End Sub

Sub DeleteButton()

WithApplication.CommandBars('Formatting').Controls(1)

If .Caption = '请选择版块' Then .Delete

EndWith

End Sub

Sub myOnA()

DimmyList As Byte

myList= Application.CommandBars('Formatting') _

.Controls(1).ListIndex

ActiveWorkbook.FollowHyperlink_

Address:='http://club./forum-'& myList & '-1.html'，NewWindow:=True

End Sub

代码解析：

AddDropdown过程使用Add方法在工具栏中添加下拉列表控制框控件。

第5行代码使用Array函数创建一个数组用于保存下拉列表控制框控件加载列表项所需的元素。

第6行代码先运行第19行到第23行的DeleteButton过程删除可能存在的下拉列表控制框控件，以免重复添加。DeleteButton过程判断工具栏中第一个控件的Caption属性是否为“请选择版块”，如果是则删除该下拉列表控制框控件。

第7、8行代码使用Add方法在工具栏中添加下拉列表控制框控件。应用于 CommandBarControls 对象的Add方法请参阅▲79 。示例中将其参数Type设置为msoControlDropdown，添加的就是下拉列表控制框控件。

第10行代码设置下拉列表控制框控件的Caption属性，应用于 CommandBarControls 对象的Caption属性返回或设置指定命令栏控件的题注文字，也可作为默认的“屏幕提示”显示。

第11行代码设置改变下拉列表控制框控件的内容时要运行的过程为第24行到第30行代码的myOnA过程。myOnA过程根据下拉列表控制框控件的ListIndex属性值打开Excel Home论坛中相应的版块。

第12行代码设置下拉列表控制框控件的样式。Style属性返回或设置命令栏控件的显示方式，该属性值可设置为表格所列MsoComboStyle常量之一。

第13行到第15行代码使用AddItem方法将数组中的元素添加到下拉列表控制框控件的列表项中。

第16行代码将下拉列表控制框控件的ListIndex属性设置为1，使其显示第一条列表项。

▲094 屏蔽工作表的复制功能

有时我们并不希望用户对工作表中的数据进行复制粘贴操作，此时可以把所有的复制功能都屏蔽，如下面的代码所示。

DimCmdCtrls As CommandBarControls

DimCmd As CommandBarControl

Sub ProCopy()

SetCmdCtrls = Application.CommandBars.FindControls(ID:=19)

ForEach Cmd In CmdCtrls

Cmd.Enabled = False

Next

Application.CellDragAndDrop= False

Application.OnKey('^c')，““

End Sub

Sub StaCopy()

SetCmdCtrls = Application.CommandBars.FindControls(ID:=19)

ForEach Cmd In CmdCtrls

Cmd.Enabled = True

Next

Application.CellDragAndDrop= True

Application.OnKey('^c')

End Sub

代码解析：

第1、2行代码在模块顶部声明两个模块级的变量。

第3行到第10行代码ProCopy过程，屏蔽工作表中所有的复制功能。其中第4行到第7行代码使用FindControls方法将所有与“复制”相关的命令栏控件赋给变量CmdCtrls后将其Enabled设置为False。关于FindControls方法请参阅▲80 。

第8行代码屏蔽单元格拖放功能，关于应用于Application对象的CellDragAndDrop属性请参阅▲10 。

第9行代码屏蔽<Ctrl+C>组合键功能，关于应用于Application 对象的OnKey方法请参阅▲68 。

第11行到第18行代码StaCopy过程，恢复所有的复制功能。