自制Excel浮动工具条

2007/7/17更新

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

或直接提取

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

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

 

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

一、原理

实际上每次打开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中添加如下代码,使添加按钮函数可以自动运行

'下代码可以实现:不论xlsxla都能够自动添加按钮

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

评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值