自制Excel浮动工具条

2007/7/17更新

如果你需要此VBA加载宏，请访问 http://my.mofile.com/benjaminwan

或直接提取

简体中文:http://pickup.mofile.com/5505481867922136

繁体中文:http://pickup.mofile.com/0900889919321666

 

本文假设读者有一定的Excel的VBA基础。故某些基础问题不做详解。

一、原理

实际上每次打开Excel，也会每次都加载宏。

故想让浮动工具条在每次打开Excel后都出现，只要在你写程序的Excel文件的Thisworkbook里做些手脚就可以了。

 

如果是XLA 文件，VBA入口为 Workbook_AddinInstall/Workbook_AddinUninstall

如果是XLS 文件，VBA入口为 Workbook_Open/Workbook_BeforeClose

一个是打开后执行的(可以用于加载工具条)，一个是要关闭前执行(可以用来卸载工具条)。

 

二、先做一个添加工具条函数吧

先添加一个模块，然后在这个模块中写入如下语句

‘先定义一下工具条的名字及工具条上按钮的名字

Public Const TECH_TOOLBAR_NAME As String = "技术工具箱"

Public Const CPK_TOOL_NAME As String = "CPK工具"

Public Const MAP_TOOL_NAME As String = "单分布图工具"

Public Const Multi_MAP_TOOL_NAME As String = "对比分布图工具"

Public Const STAMP_TOOL_NAME As String = "电子印章工具"

Public Const ABOUT_TOOL_NAME As String = "关于"

 

‘下面写一个添加工具条的函数

Public Sub AddToolbar()

Dim mybar As Object

 

'添加工具条，msoBarTop即代表浮动工具条

Application.CommandBars.Add Name:=TECH_TOOLBAR_NAME, >

CommandBars(TECH_TOOLBAR_NAME).Visible = True

 

'添加CPK按钮，Before:=1代表这个按钮在工具条的第一格

Set mybar = Application.CommandBars(TECH_TOOLBAR_NAME).Controls.Add(Type:=msoControlButton, Before:=1)

ThisWorkbook.Worksheets("source").Shapes("Icon_CPK").Copy  '设置按钮图标

'这一步要先在此文档里建一个名为source的工作表，然后再这工作表里帖入一个图像或艺

’术字，并把这个图像的名称改为Icon_CPK

With mybar

.OnAction = "show_CPK_window"   '按下此按钮要执行的函数

.PasteFace

.TooltipText = CPK_TOOL_NAME    '鼠标停在此按钮上要显示的文字

End With

 

'添加单分布图工具按钮

Set mybar = Application.CommandBars(TECH_TOOLBAR_NAME).Controls.Add(Type:=msoControlButton, Before:=2)

ThisWorkbook.Worksheets("source").Shapes("Icon_MAP").Copy

With mybar

.OnAction = "show_MAP_window"

.PasteFace

.TooltipText = MAP_TOOL_NAME

End With

 

'添加对比分布图工具按钮

Set mybar = Application.CommandBars(TECH_TOOLBAR_NAME).Controls.Add(Type:=msoControlButton, Before:=3)

ThisWorkbook.Worksheets("source").Shapes("ICON_MAP_Multi").Copy

With mybar

.OnAction = "show_multi_MAP_window"

.PasteFace

.TooltipText = Multi_MAP_TOOL_NAME

End With

 

'添加电子印章工具按钮

Set mybar = Application.CommandBars(TECH_TOOLBAR_NAME).Controls.Add(Type:=msoControlButton, Before:=4)

ThisWorkbook.Worksheets("source").Shapes("ICON_STAMP").Copy

With mybar

.OnAction = "show_STAMP_window"

.PasteFace

.TooltipText = STAMP_TOOL_NAME

End With

 

'添加about按钮

Set mybar = Application.CommandBars(TECH_TOOLBAR_NAME).Controls.Add(Type:=msoControlButton, Before:=5)

ThisWorkbook.Worksheets("source").Shapes("ICON_about").Copy

With mybar

.OnAction = "show_about_window"

.PasteFace

.TooltipText = ABOUT_TOOL_NAME

End With

End Sub

 

三、删除工具条

Public Sub Delmenu()

Application.CommandBars(TECH_TOOLBAR_NAME).Delete

End Sub

 

四、在Thisworkbook中添加如下代码，使添加按钮函数可以自动运行

'下代码可以实现：不论xls或xla都能够自动添加按钮

Private Sub Workbook_AddinInstall()

Application.ScreenUpdating = False

If GetSetting("TECH_tools", "Startup", "toolbar") = "" Then

SaveSetting "TECH_tools", "Startup", "toolbar", "1"

Call AddToolbar

End If

Application.ScreenUpdating = True

End Sub

 

Private Sub Workbook_AddinUninstall()

Dim tempbar As CommandBars

On Error Resume Next

If Application.CommandBars(TECH_TOOLBAR_NAME).Name = TECH_TOOLBAR_NAME Then

End If

If Err.Number <> 0 Then

Err.Clear

SaveSetting "TECH_tools", "Startup", "toolbar", ""

End If

End Sub

 

Private Sub Workbook_Open()

Call Workbook_AddinInstall

End Sub

 

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Call Workbook_AddinUninstall

End Sub

------------------------------------------

benjaminwan

2007-6-17