通过VBA自定义向Excel添加工具栏

发布时间：2010-12-06 13:59:09

通过VBA自定义向Excel添加工具栏

Office由于提供了VBA,为大家开发一些定制功能提供了一种途径。但是如何实现工具栏中的命令与宏进行绑定，对于初学则来说是一个不小的门槛。

今天,给大家介绍一下在Excel里写完宏后,如何通过宏自动生成工具栏。

如图：

在VBA中将要用到CommandBar，CommandBarButton两个对象。

Option Explicit

'定义全局变量

Private zyi_Bar As CommandBar

Private zyi_ComBarBtn As CommandBarButton

'-------------------------------------------------------------------------------------------------------------

'增加工具栏

'-------------------------------------------------------------------------------------------------------------

Sub AddToolBar()

' Application.CommandBars.Add(Name:="zy").Visible = True

Dim strBarName As String

Dim strParam As String

Dim strCaption As String

Dim strCommand As String

Dim nIndex As Integer

Dim nFaceId As Integer

Dim cBar As CommandBar

strBarName = "ZYI_TOOL"

For Each cBar In Application.CommandBars

If cBar.Name = strBarName Then

Set zyi_Bar = cBar

GoTo 20

End If

'On Error GoTo 10

'Set zyi_Bar = Application.CommandBars(strBarName)

'If zyi_Bar.Name = strBarName Then

' GoTo 20 '已经存在

' zyi_Bar.Delete

'End If

'10:

On Error GoTo 100

Set zyi_Bar = Application.CommandBars.Add(Name:=strBarName)

20:

zyi_Bar.Visible = True

On Error GoTo 100

'-----------------------------------------------------------

'1. 复制工作表

nIndex = 1

strCaption = "复制工作表"

strParam = "复制工作表的单元格内容及格式!"

strCommand = "复制工作表"

nFaceId = 271

If zyi_Bar.Controls.Count < nIndex Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

ElseIf zyi_Bar.Controls(nIndex).Caption <> strCaption Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

End If

'-----------------------------------------------------------

'2. 合并单元格

nIndex = 2

strCaption = "合并单元格"

strParam = "合并单元格以及居中"

strCommand = "合并单元格"

nFaceId = 29

If zyi_Bar.Controls.Count < nIndex Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

ElseIf zyi_Bar.Controls(nIndex).Caption <> strCaption Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

End If

'-----------------------------------------------------------

'3. 居中

nIndex = 3

strCaption = "居中"

strParam = "水平垂直居中"

strCommand = "居中单元格"

nFaceId = 482

If zyi_Bar.Controls.Count < nIndex Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

ElseIf zyi_Bar.Controls(nIndex).Caption <> strCaption Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

End If

'-----------------------------------------------------------

'4. 货币

nIndex = 4

strCaption = "货币"

strParam = "货币"

strCommand = "货币"

nFaceId = 272

If zyi_Bar.Controls.Count < nIndex Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

ElseIf zyi_Bar.Controls(nIndex).Caption <> strCaption Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

End If

'-----------------------------------------------------------

'5. 将货币数字转换为大写

nIndex = 5

strCaption = "删除列"

strParam = "删除列"

'宏名称

strCommand = "删除列"

nFaceId = 1668

If zyi_Bar.Controls.Count < nIndex Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

ElseIf zyi_Bar.Controls(nIndex).Caption <> strCaption Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

End If

nIndex = nIndex + 1

While nIndex < zyi_Bar.Controls.Count

zyi_Bar.Controls(nIndex).Delete

Wend

'-----------------------------------------------------------

'6. 分割条

zyi_Bar.Controls(zyi_Bar.Controls.Count).BeginGroup = True

'-----------------------------------------------------------

'7. 将货币数字转换为大写

nIndex = 6

strCaption = "人民币"

strParam = "人民币由数字转换为大写"

'宏名称

strCommand = "To大写人民币"

nFaceId = 384

If zyi_Bar.Controls.Count < nIndex Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

ElseIf zyi_Bar.Controls(nIndex).Caption <> strCaption Then

AddComBarBtn strParam, strCaption, strCommand, nIndex, nFaceId

End If

nIndex = nIndex + 1

While nIndex < zyi_Bar.Controls.Count

zyi_Bar.Controls(nIndex).Delete

Wend

'-----------------------------------------------------------

'9. 分割条

zyi_Bar.Controls(zyi_Bar.Controls.Count).BeginGroup = True

100:

End Sub

'-------------------------------------------------------------------------------------------------------------

'向工具栏动态添加按钮

'-------------------------------------------------------------------------------------------------------------

Sub AddComBarBtn(strParam As String, strCaption As String, strCommand As String, nIndex As Integer, nFaceId As Integer)

Set zyi_ComBarBtn = zyi_Bar.Controls.Add( _

ID:=1, _

Parameter:=strParam, _

Before:=nIndex, _

Temporary:=True)

With zyi_ComBarBtn

.Caption = strCaption

.Visible = True

.OnAction = strCommand

.FaceId = nFaceId

End With

End Sub

通过以上两个函数，就可以实现自动添加工具栏及按钮。

剩下将在Workbook_Open函数里调用AddToolBar,即可实现文件打开就会显示工具栏。如果仅作为工具存放，则可以把该文件保存为模版文件，即xxx.xla。

Private Sub Workbook_Open()

' MsgBox "欢迎使用Excel", vbInformation + vbOKOnly, "增强工具"

Application.StatusBar = "欢迎使用增强工具：zyi"

'显示工具栏

AddToolBar

End Sub

到此，一个来工具栏的宏大功告成了。

本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/tomyi/archive/2009/02/18/3905735.aspx

VBA自定义菜单和菜单栏(一)

作者：佚名文章来源：本站原创更新时间：2009-9-12

前言

在EXCEL中，我们的操作都是通过“工具栏、菜单栏、快捷菜”单实现。EXCEL通过菜单给我们提供基本操作功能之外，也为我们提供了扩展自定义功能的接口，即自定义自己的工具栏、菜单栏。

本文着重介绍如何在 Excel 2003版本中通过编程方式自定义菜单和菜单栏方法。其中包含Excel 中管理和自定义菜单栏、菜单、命令、子菜单和快捷菜单，我将通过代码实例分步说明。

与大家分享关于VBA实现菜单栏管理与自定义菜单栏功能的实现。

一、简介

在 Microsoft Excel 2000以上版本中实现许与自定义菜单栏和菜单相关的常见任务，可以使用“自定义”对话框（见图1.1）。但如果要实现较高级任务或为自定义程序定制菜单栏和菜单，就需要创建 Microsoft Visual Basic for Applications (VBA)代码。

有关如何使用“自定义”对话框的更多信息，你可以单击“帮助”菜单上的“Microsoft Excel帮助”，在“Office 助手”或“搜索向导”中键入自定义菜单栏，然后单击“搜索”查看主题。

二、命令栏

在 Microsoft Office中，所有工具栏、菜单栏和快捷菜单都是被作为“命令栏”这样一种对象以编程方式控制的。下列所有项目在VBA中皆用 CommandBar对象表示：

● 菜单栏、工具栏和快捷菜单。

● 菜单栏和工具栏上的菜单。

● 菜单、子菜单和快捷菜单上的子菜单。

您可以修改任何内置的菜单栏和工具栏，还可以创建和修改用您自己的VBA代码交付的自定义工具栏、菜单栏和快捷菜单。您可以将程序功能以单个按钮的形式放在工具栏上，或以命令名称组的形式放在菜单上。因为工具栏和菜单都是命令栏，所以可以使用同一类型的控件。

在 VBA 和 Microsoft Visual Basic中，按钮和菜单项用 CommandBarButton 对象表示。显示菜单和子菜单的弹出控件用 CommandBarPopup 对象表示。在以下示例中，名为“Menu”的控件和名为“Submenu”的控件都是用于显示菜单和子菜单的弹出控件，并且这两个控件是各自的控件集中唯一的 CommandBar 对象。

在 Microsoft Excel中，菜单栏和工具栏被视为是同一种可编程对象，即 CommandBar 对象。可以使用 CommandBar 对象中的控件来指代菜单、菜单项、子菜单和快捷菜单。可以在 Type 参数中使用一个常量为每个控件指定要用于菜单、子菜单或命令的控件类型。

三、控件常量

下面是Excel 2003 中的各种控件常量的列表，这些常量指定用于特定菜单栏控件的图形控件类型：

•MsoControlActiveX*

•MsoControlAutoCompleteCombo***

•MsoControlButton

•MsoControlButtonDropdown

•MsoControlButtonPopup

•MsoControlComboBox

•MsoControlCustom

•MsoControlDropdown

•MsoControlEdit

•MsoControlExpandingGrid

•MsoControlGauge

•MsoControlGenericDropdown

•MsoControlGraphicCombo

•MsoControlGraphicDropdown

•MsoControlGraphicPopup

•MsoControlGrid

•MsoControlLabel

•MsoControlLabelEx***

•MsoControlOCXDropDown

• MsoControlPane **

•MsoControlPopup

•MsoControlSpinner***

•MsoControlSplitButtonMRUPopup

•MsoControlSplitButtonPopup

•MsoControlSplitDropdown

•MsoControlSplitExpandingGrid

•MsoControlWorkPane**

*表示Microsoft Excel 2000中的新增项

**表示Microsoft Excel 2002中的新增项

***表示Microsoft Office Excel 2003中的新增项

四、菜单栏

菜单栏是一种命令栏。它是一种可在其中添加菜单、菜单项和子菜单的对象。

有关如何在Excel中管理菜单栏和菜单项的更多信息，请按照下列步骤操作：

1.启动 Microsoft Visual Basic编辑器。

2.在“帮助”菜单上，单击“Microsoft Visual Basic 帮助”。

3.在“Office 助手”框或“应答向导”框中，键入菜单栏，然后单击“搜索”。

4.在 Excel 2003和 Excel 2002中，单击“添加和管理菜单栏和菜单项”。在 Excel 2000中，单击“关于菜单和工具栏”。

可以在运行时修改菜单栏及该菜单栏上的控件。对菜单栏所做的更改可能会影响菜单栏的外观或位置。可对控件进行的更改取决于控件类型。下表列出了最常见的属性和常用于更改控件的状态、操作或内容的方法：

4.1 Add方法应用于CommandBars对象

新建一个命令栏并添加到命令栏集合。返回 CommandBar 对象。

expression.Add ( Name , Position , MenuBar , Temporary )

● expression必需。该表达式返回一个CommandBars对象。

● Name（Variant类型）可选。新命令栏的名称。如果忽略该参数，则为命令栏指定默认名称（例如：Custom 1）。

● Position（Variant类型）可选。新命令栏的位置或类型。可以为下表所列的MsoBarPosition常量之一。

● MenuBar (Variant类型）可选。设置为True将以新命令栏替换活动菜单栏。默认值为 False。

● Temporary (Variant类型)可选。设置为 True 将使新命令栏为临时命令栏。临时命令栏在关闭容器应用程序时删除。默认值为 False。

4.2返回命令栏控件的 ID

以下代码示例返回活动菜单栏的ID：

Sub Id_Control ()

Dim myId as Object

Set myId = CommandBars("Worksheet Menu Bar").Controls("工具(&T)")

MsgBox myId.Caption & Chr(13) & MyId.Id

End Sub

4.3确定活动菜单栏的名称

以下代码示例返回活动菜单栏的名称：

Sub MenuBars_GetName()

MsgBox CommandBars.ActiveMenuBar.Name

End Sub

4.4保存（内置或自定义菜单栏的）活动状态

您可能需要将originalMenuBar变量声明为公共变量，这样，子例程就可以在其他子例程（如Auto_Close子例程）中使用该变量。以这种方式声明和使用该变量会将用户的上一个菜单栏重置为初始状态。以下示例宏重置菜单栏：

Public originalMenuBar as Object

Sub MenuBars_Capture()

Set originalMenuBar = CommandBars.ActiveMenuBar

End Sub

4.5创建自定义命令栏

以下代码示例创建名为My Command Bar的自定义命令栏：

Sub MenuBar_Create()

Application.CommandBars.Add Name:="My command bar"

End Sub

您还可以通过使用Temporary:=True参数来创建自定义命令栏。Temporary:=True参数允许命令栏在您退出 Excel 时自动重置。以下代码使用Temporary:=True参数创建自定义命令栏：

Sub MenuBar_Create()

Application.CommandBars.Add Name:="My command bar", Temporary:=True

End Sub

4.6显示自定义命令栏

以下示例创建并显示自定义的“My Custom Bar”菜单栏，然后用它替换内置的菜单栏：

Sub MenuBar_Show()

Dim myNewBar As Object

Set myNewBar = CommandBars.Add(Name:="Custom1", Position:=msoBarFloating)

'您必须先启用您的自定义菜单栏，然后看见它。

'使菜单栏添加到自定义对话框列表中的可用菜单栏上。

'设置菜单属性设置为True取代内置的菜单栏。

myNewBar.Enabled = True

myNewBar.Visible = True

End Sub

4.7删除自定义命令栏

以下代码示例删除名为“Custom 1”的自定义菜单栏：

Sub MenuBar_Delete()

CommandBars("Custom1").Delete

End Sub

4.8隐藏命令栏

以下代码示例从可用菜单栏列表中删除内置“图表”菜单栏：

Sub MenuBar_Display()

CommandBars("Chart").Enabled = False

End Sub

4.9显示命令栏

以下代码示例从可用菜单栏中添加内置“图表”菜单栏：

Sub MenuBar_Display()

CommandBars("Chart").Enabled = True

End Sub

4.10还原内置命令栏

还原菜单栏会重置（菜单和菜单项的）默认控件。示例代码还原内置“图表”菜单栏：

Sub MenuBar_Restore()

CommandBars("Chart").Reset

End Sub

注意：您只能重置内置菜单栏，不能重置自定义菜单栏。

VBA之宏基本础篇-自定义Excel(9)

前面几贴的自定义基本都是Excel的功能，只是可能大家没有仔细总结，后面的自定义就基本是用VBA来完成的。我曾经说过，在excel的应用中，我还中最喜欢VBA和学习研究VBA，ZSH_000也有一贴VBA的入门贴，那我也来讲讲我心中对VBA的认识。

什么是宏？宏是VBA语言编出的一段程序，是一系列命令和函数，存储于 Visual Basic 模块中，并且在需要执行该项任务时可随时运行。

什么是VBA？VBA是Visual Basic for Applications 的简称，Visual Basic（VB）在office的应用版。 VBA是与VB类似或者对大家说可以说是一样的语言，而VB是以易用易学著称！我以前曾经考过二级的C，后来本来想学C++却因自己一个人学习，倍感困难而放弃。但从一个偶然的机会发现Office里的VBA起而开始学习VB，但后来大部份都是在VBA里学习，而没有进一步再去，但学习VB的途径会比较多，大家也可能从学习VB开始。

宏有什么用？如果经常在 Microsoft Excel 中重复某项任务，那么可以用宏自动执行该任务。这是宏在Excel帮助中的用途，而宏的用处不仅仅在于此。就象有人说，VB能干什么？而有人回答，什么都可以！但个人认为，不一定什么东西非要用VBA，Excel中本身自带的很多功能都能解决很多的问题！但这些功能也都能通过代码的方式来表达！

怎么开始学习VBA？这是不少吧友常问的问题之一。个人认为学习什么东西，最好的开始是兴趣，本贴的创建的原因也在于此。后面的内容可能大家在工作与生活中都没有什么实际的用处，但我希望后面的内容能引起大家对VBA编程的兴趣。而开始学习VBA我认为第一步从录制宏开始。

何为录制宏？录制宏是excel的一个功能，它能将用户的操作转化为代码，这样即使你一点都不懂得编程，也可以通过录制宏来生成一段宏！这个功能在工具菜单/宏中。点击录制新宏，在选择保存的地方（个人宏工作簿/当前工作簿或新工作簿），接着只要按我们平时的操作过程操作Excel，完了之后按停止录制宏结束，这样就可以生成一段宏程序。

录制宏的功能有何用？除了能生成一段宏外，我们还可以将操作的过程序变成宏后，再通过其代码来了解这过程的相关要用到的属性啦，方法啦等，对于初学者，这是一个非常好的自学方法之一。

从哪可以看到宏代码？宏我们录制好了，那我们从哪里可以看到我们录好的宏的代码呢？点击工具/宏/VBA编辑器或按Alt+F11，就可以进入VBA编辑器，在里面就可以看到我们录制好的代码。

怎么运行宏？从工具/宏/宏中，通过选择其中的名称，就可以运行我们的宏了，当然我们也可以在VBA编辑器中运行宏，先将光标移到宏所在的代码中，再点击运行菜单中的运行子过程或窗体，或按工具栏中的相应的按钮，或用快捷键F5，就可以运行子过程了，注意！！！宏对文件的一切操作是不可撤消的，在不了解宏的功能之前，最好的方法是先保存文件（更好就备份一份啦），然后再运行宏，如果发现宏运行后的结果有误，就可以关闭文件且不保存，这样再打开文件就可以还原到运行宏前的状态（注：宏也可以自行保存文件，这时这个办法就无效了）

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/14.html

VBA之宏操作篇-自定义Excel(10)

其实这一篇与上一篇是写给完全不了解VBA的朋友，让他们也可能体会一下之后的功能，但！这个贴子的内容，我在上篇已说过，目的是让吧友们对VBA产生兴趣而不是教大家从零开始！

怎么获得帮助？还记得第一贴中我的见意了吗？现在就要用到VBA的帮助了！在VBA编辑器中按F1即可调出VBA的帮助，如果大家有兴趣细细地看上一次（全部哦！），那你一定会从中收获不少的。如果更快地获得帮助，找到帮助的内容呢？一个当然就是在索引与应答向导里寻找，另一个就是先选择代码中的词，再按F1即可。

第一个宏！上贴已介绍大家如何利用录制宏生成我们的宏代码，而这一贴，我来介绍如何利用VBA编辑器来创建一个宏！学过编程的朋友都知道有名的Hello!World!的程序，那我们现在就来创建这个宏！

新建一个文件后，保存这hello，然后进入VBA编辑器，在工程资源管理器中选择这个hello工程（默认在左上侧的窗口，看不到工程资源管理器，可以点击菜单视图/工程资源管理器或按Ctrl+R，工具栏中也有对应的按钮)，然后点击插入/模块（工具栏中也有相应按钮），这时工程资源管理器就会多了一个模块，里面就多了一个模块1（也有可能是英文名），双击这个东东，就可以编辑我们的代码了。

接下来在菜单插入/过程中添过一个子程序，名称命名为hello，点击确定后就会自动生成一个过程序的头Public Sub hello()和尾End Sub，那么我们的代码就可以在这之间加入了！

这个程序我们用三行代码做三件事！在A1格中写入Hello!World!，在立即窗口（默认在右下方，没有看到立即窗口，也在视图中点击立即窗口让它显示）中写入Hello!World!，用一个消息框弹出Hello!World!，三行代码为：

Range("A1").Value = "Hello!World!"

Debug.Print "Hello!World!"

MsgBox "Hello!World!"

运行宏后就各到我们上面要做的事情了！

最后再说几个VBA有关的概念：

什么叫个人宏工作簿？个人宏工作簿名称为PERSONAL.XLS，如果存在，是随EXCEL启动而打开的，可以从窗口/取消隐藏看到它的真面目，第一次可以录制一个宏并保存在个人宏工作簿来生成它。

怎样才能将网页代码移到你的文件中？复制，粘贴到你的代码窗口即可，有些朋友可能没有包含过程的头与尾，自行加入即可。

怎样才能将一个文件的代码移到另一个文件？除了上面说的方法，还可以导出整个模块（右击该模块）再导入（右击需要导入的工程）即可。

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/15.html

自定义Excel函数-自定义Excel(11)

这一贴说的是自定义函数。Excel本身已自带了很多函数，供我们使用，但有些问题用原有的函数解决起来很复杂，甚至是无能为力，但有了VBA，可能就可以现实。

怎样自定义一个函数？下面我们建一个名为RangeCount和函数，用来统计给定单元格数量。上贴说过怎么插入一个宏（子程序），其实细心的朋友就会发现，里面有一项函数的选项，就是用这个添加了！键入你需要的名称RangeCount，即会自动生成一个函数的头Public Function RangeCount()和尾End Function!这时大家可以知道，子程序都是以Sub关键字开头，而函数是以Function关键字开头。

怎样给自定义函数传递参数？用过Sum函数的朋友都知道Sum的用法，在单元格中键入=Sum(A1:A10)就能对A1:A10进行求和，那么怎么让我们的自定义函数也有此功能呢，其实很简单，只要在Function RangeCount()中的（与）之间加入即可，象现在我们要给这个自定义函数传递一个单元格的参数，即在（）间加入XRan As Range即可。其中XRan就是我们给这个参数设定的名称，As 是关键字，而Range就是给定参当数的类型（单元格类型），更详细的说明可以参见VBA的帮助（上贴有说明怎么用帮助了吧：））。

怎么样自定义函数加入功能？其实也和子程序一样，在函数的头Public Function RangeCount()和尾End Function之间就可以加入代码，我们这个函数的代码只有一句：RangeCount = XRan.Count

怎么样让自定义函数返回值？从上面的例子看出，只要将函数的名称设定为需要返回的值即可。

怎么当前工作表中使用自定久函数？使用自定义函数的方法其实和一般函数的方法是一样的，在单元格中键入=RangeCount(A1:A10)，即可以得到值（10）！当然，也可以通过菜单插入/函数，在类别中选择用户自定义里找到你自定义的函数。

怎么在工作表里使用别的工作表里的自定义函数？从菜单插入/函数，类别中的用户自定义里，可以看到，如果这个自定义函数不是在当前的工作表里的，函数会变成——文件名.xls!函数名了，这样我们使用上面的自定义函数就变成=Book1.xls!RangeCount(A1:A10)（设我们刚才保存文件为Book1)。

怎么样在任何工作表中使用自定义函数？自定义了函数后，每一次使用都要打开这个工作簿，不方便，那么怎么样让任何工作簿都能使用这个自定义函数呢？有两个方法，第一个就是把代码写在上面说到的个人宏工作簿中，因为个人宏工作簿都是随Excel自动打开的，那么我们就可以通过PERSONAL.XLS!函数名来使用这个自定义函数。第二个方法就是加载宏（关于加载宏的其它用法和具体说明以后还会有专门的一贴），将包含这个自定义函数的工作簿，去掉无关的内容（不去当然也行啦！）后另存为加载宏（不会不知道怎么另存吧，汗！后注！），这样在菜单工具/加载宏里，将相关项前打勾，即可使用该自定义函数，这时使用函数的方法只要直接用函数名即可，如=RangeCount(A1:A10)。

最后再说一点大家少遇到的现象：用过VBA后，大家知道在同一模块中是不能有相同名称的子程序与函数的，如果有，运行时会提示存在二义性！但在不同模块中，却能有相同甸称的函数存在，那么怎么使用这样的函数呢？从菜单插入/函数，类别中的用户自定义里，我们可以看出这样的函数变成模块名.函数名了，这样我们的使用方法就是=模块1.RangeCount(A1:A10)或=模块2.RangeCount(A1:A10)。

后注：详细的另存为加载宏的过程，点击菜单/文件/另存为，在文件类型里选择Microsoft Excel加载宏项，这时文件夹自动转到保存加载宏的AddIns，再保存即可。

附：上面RangeCount的完整代码：

Function RangeCount(XRan As Range)

RangeCount = XRan.Count

End Function

下面给出两个自定义函数，按给颜色求和SumColor与计数CountColor

Function SumColor(rColor As Range, rSumRange As Range)

Dim rCell As Range

Dim iCol As Integer

Dim vResult

Application.Volatile

iCol = rColor.Interior.ColorIndex

For Each rCell In rSumRange

If rCell.Interior.ColorIndex = iCol Then

vResult = WorksheetFunction.Sum(rCell) + vResult

End If

Next rCell

SumColor = vResult

End Function

Function CountColor(rColor As Range, rSumRange As Range)

Dim rCell As Range

Dim iCol As Integer

Dim vResult

Application.Volatile

iCol = rColor.Interior.ColorIndex

For Each rCell In rSumRange

If rCell.Interior.ColorIndex = iCol Then

vResult = vResult + 1

End If

Next rCell

CountColor = vResult

End Function

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/16.html

自定义Excel加载宏-自定义Excel(12)

什么是加载宏？加载宏程序是一类程序，它们为 Microsoft Excel 添加可选的命令和功能。

加载宏的分类！Excel 有三种类型的加载宏程序：Excel 加载宏、自定义的组件对象模型 (COM) 加载宏和自动化加载宏。而我们这里说的和以后讲的加载宏都是第一类加载宏。

"如何安装加载宏？在使用某个加载宏前，必须先将其安装在计算机上，再将其加载到 Excel 中。默认情况下，加载宏（*.xla 文件）将安装在以下某个位置上：

Microsoft Office/Office 文件夹的 Library 文件夹或其中的某个子文件夹。

Documents and Settings//Application Data/Microsoft/AddIns 文件夹。你也可以将XLS文件，通过文件/另存为，将其另存为Xla加载宏文件。"

如何将加载宏装入 Excel？安装完加载宏之后，还必须将加载宏装入 Excel。在工具/加载宏中，里面就列出你电脑中的所有安装的加载宏项，将对应项的勾勾选上即可加载加载宏。

如何卸载 Excel中的加载宏？相对应，在工具/加载宏中，里面就列出你电脑中的所有安装的加载宏项，将对应项的勾勾去除即可。将加载宏卸载只是从 Excel 中删除加载宏的功能和命令，但计算机上依然保留着加载宏程序，因此您还可以轻松地重新装载该加载宏。

如何在加载宏加载和关闭时运行特定的代码？在AddinInstall 事件和AddinUnInstall 事件中加入相应的代码即可，当然，这是加载宏加载和关闭时特有的事件，你可以选择在Workbook_open（打开）和Workbook_BeforeClose（关闭)中加入相应的加代。

如何在自定义的加载宏中加入说明？细心的朋友会发现，当我们选择每个Excel自带的加载宏时，在其下方会有一段文字说明这个加载宏，其实我们自定义的加载宏里也可以自已加入一段说明的，只要在其文件/属性的备注中写入这段说明即可，这样看起来是不是专业一点*~_~*，也方便让其它使用加载宏的朋友在加载前多一点了解它。

加载宏就说到这里了，再加上前面的说明，你是不是可以将以前的自定义函数啦，宏啦用加载宏分发别其他朋友了：），再下面的几项自定义项，能让你的一些不懂VBA的朋友更能易用你编好的加载宏，敬请关注哦！

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/17.html

自定义Excel菜单项-自定义Excel(13)

上贴讲过了加载宏，并见意大家将以前的自定义函数啦，宏啦用加载宏分发别其他朋友。自定义函数包含在加载宏后的使用方法前面已说过，而宏呢？如果让别人使用加载宏里的宏？

在宏的基础篇中，我们已说过宏怎么运行，但其实最方便的方法就是在我们的工具栏中建立一个按钮来调用这个宏。

怎么自定义一个按钮？首先要确保要更改的工具栏是可见的，再单击“工具栏选项”箭头指向“添加或删除按钮”或用右击单击工具栏，再单击“自定义”，单击“命令”选项卡，在类别中选择“宏”，将“自定义按钮”拖拉到你需要的工具栏的位置即可。而有多项的话，我们还可以自定义一个菜单项来包含这一些按钮。

怎么自定义一个菜单项？和自定义按钮是差不多的，只是最后一步的操作是将“自定义菜单项”拖拉到你需要的工具栏的位置即可。

怎么将按钮与宏关联？刚刚建立好的按钮，在第一次单击它是，会弹出一个菜单，让你选择与其相关联的宏，这时选择要关联的宏的名称即可。但我们可以这样操作，右击工具栏后选择“自定义”，选择需要关联宏的按钮，然后在“更改所选内容”中的指定宏中指定或修改！

如何更改这个自定义按钮的外观？在刚才说的“更改所选内容”项里，还可以更改这个按钮的名称，图标，样式，只要在此做相应的修改即可，要说明的一点是，在名称中用&后面跟着英文的话，就变成相对应的键盘按键，修改后我们看到的是这个英文下面加一条划线来表示！

如何删除自定义的菜单？还按照上面的操作，将要删除的菜单拖拉到工具栏外，或选择它，再点击“更改所选内容”里的删除即可。

上面说了手工怎么样建立的删除自己的菜单，而怎么让加载宏自己建一个菜单，并在关闭时将其删除呢？前贴说过，可以在AddinInstall 事件与AddinUnInstall 事件或者Workbook_open事情和Workbook_BeforeClose事件中，加入代码，来让加载宏打开与关闭时运行这些代码，还有一个方法就是在模块中定义auto_open（打开时运行）与auto_close（关闭时运行）这两个过程来实现，下面给出一个例子：

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Dim AName, MName(2, 1), DelMenu(2) As Boolean

Sub auto_open()

Dim MyMenu As CommandBarPopup

Dim MyBtn As CommandBarButton

Dim i As Byte

Dim XT As String

On Error Resume Next

AName = "自定义(&Z)" '菜单名称

MName(0, 0) = "百度Excel吧(&A)" '菜单项名称

MName(0, 1) = "BaiDuExcelBa" '指定宏名称

MName(1, 0) = "Excel吧主页(&B)" '菜单项名称

MName(1, 1) = "ExcelBaZy" '指定宏名称

MName(2, 0) = "Excel各页名(&C)" '菜单项名称

MName(2, 1) = "Excel各页名" '指定宏名称

Set MyMenu = CommandBars("Worksheet Menu Bar").Controls(AName)

If MyMenu Is Nothing Then

Set MyMenu = CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)

MyMenu.Caption = AName

End If

For i = 0 To UBound(MName)

Set MyBtn = MyMenu.CommandBar.Controls(MName(i, 0))

If MyBtn Is Nothing Then

DelMenu(i) = True

Set MyBtn = MyMenu.CommandBar.Controls.Add(Type:=msoControlButton)

With MyBtn

.Style = msoButtonIconAndCaption

.FaceId = 79 + MyBtn.Index

.Caption = MName(i, 0)

.OnAction = MName(i, 1)

End With

Else

DelMenu(i) = False

XT = XT & vbCrLf & MName(i, 0)

End If

Set MyBtn = Nothing

If Len(XT) > 0 Then

MsgBox "已存在菜单名：" & XT & vbCrLf & "不能再被加载！", vbExclamation, "错误"

End If

End Sub

Sub auto_close()

Dim MyMenu As CommandBarPopup

Dim MyBtn As CommandBarButton

Dim i As Byte

On Error Resume Next

Set MyMenu = CommandBars("Worksheet Menu Bar").Controls(AName)

For i = 0 To UBound(MName)

If DelMenu(i) Then

Set MyBtn = MyMenu.CommandBar.Controls(MName(i, 0))

If MyBtn Is Nothing Then

Error = True

Else

MyBtn.Delete

End If

If MyMenu.CommandBar.Controls.Count = 0 Then

MyMenu.Delete

Else

For i = 1 To MyMenu.CommandBar.Controls.Count

Set MyBtn = MyMenu.Controls(i)

MyBtn.FaceId = MyBtn.Index + 79

End If

If Err.Number > 0 Then

MsgBox "文件关闭时卸载菜单发生异常！" & vbCrLf & _

"自动生成的菜单可能已被卸载！" & vbCrLf & _

"或生成的菜单没有完全被卸载！", vbExclamation, "错误"

End If

End Sub

Sub Excel各页名()

Dim XStr, YStr, ZStr

XStr = " -"

ZStr = ""

For i = 1 To Worksheets.Count

If Worksheets(i).Name = "目录" Then

Exit For

End If

If i > Worksheets.Count Then

Sheets.Add

ActiveSheet.Name = "目录"

End If

Sheets("目录").Move Before:=Sheets(1)

Sheets("目录").Select

Range("A:B").Clear

Range("B:B").NumberFormatLocal = "@"

Worksheets(1).Cells(1, 1).Value = "序号"

Worksheets(1).Cells(1, 2).Value = "名称"

For i = 2 To Worksheets.Count

Worksheets(1).Cells(i, 1).Value = i

Worksheets(1).Cells(i, 2).Value = Worksheets(i).Name

For j = 1 To Len(Worksheets(i).Name)

YStr = Mid(Worksheets(i).Name, j, 1)

If InStr(XStr, YStr) <> 0 Then

ZStr = "'"

Exit For

End If

ActiveSheet.Hyperlinks.Add Anchor:=Worksheets(1).Cells(i, 2), Address:="", SubAddress:=ZStr & Worksheets(i).Name & ZStr & "!A1", TextToDisplay:=Worksheets(i).Name

Range("A:A").HorizontalAlignment = xlLeft

End Sub

Sub BaiDuExcelBa()

StartDoc "http://post.baidu.com/f?kw=excel"

End Sub

Sub ExcelbaZy()

StartDoc "http://www.excelba.com/index.htm "

End Sub

Function StartDoc(DocName As String) As Long

Dim Scr_hDC As Long

Scr_hDC = GetDesktopWindow()

StartDoc = ShellExecute(Scr_hDC, "Open", DocName, "", "C:\", 1)

End Function

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/18.html

自定义Excel工具栏-自定义Excel(14)

当一次性要加入多个菜单的时候，我们还可以自定义一个工具栏，这样不但可以集中处理，还方便我们维护，比如要还原可以删除整个工具栏即可，而不用一个个菜单删除。

还是先说一下怎么用手工加入一个工具栏。单击“工具栏选项”箭头指向“添加或删除按钮”或用右击单击工具栏，再单击“自定义”，单击“工具栏”选项卡，有一个新建按钮，点击后键入工具栏的名称，就可以新建一个工具栏。

相对应，删除一个工具栏，就是在“工具栏”选项卡中选择相应的工具栏，再点击删除按钮即可删除。

接下来是怎样在文件打开时将工具栏加入别人的电脑中。

第一种方法是不用VBA的，首先在你的电脑中创建好整个工具栏，包括其中的菜单项，然后还是在“自定义”里的工具栏选卡里，选择你自定义好的工具栏，再点击附加，将这个工具栏附加到你的文件中，这样保存文件后，每次打开这个文件都会将文件里包含的工具栏附加到现有的工具栏中，当然，这样在别人打开你的文件时也会如此。

第二种当然还是用VBA的方法，下面还是举个实例，这个实例是一个列出Excel自带图标的工具栏的加载宏：

首先是在文件打开是建立工具栏，即在ThisWorkBook中加入Workbook_Open事件，代码如下：

Private Sub Workbook_Open()

BarAdd '加入工具栏的代码，包含在main模块中

End Sub

而在文件关闭时删除这个工具栏，即在ThisWorkBook中加入Workbook_BeforeClose事件，代码如下：

Private Sub Workbook_BeforeClose(Cancel As Boolean)

BarDel '删除工具栏的代码，包含在main模块中

End Sub

下面是main的代码，包含加入与删除工具栏的代码和各按钮的代码，这里只贴出加入工具栏的代码BarAdd和删除工具栏的代码 BarDel：

Sub BarAdd()

On Error GoTo Error

Dim IBar As CommandBar, ICon As CommandBarButton, ICom As CommandBarComboBox

ANum = 0

Set IBar = Application.CommandBars.Add(Name:="IconId")

IBar.Visible = True

IBar.Position = msoBarTop

Set ICon = IBar.Controls.Add(Type:=msoControlButton)

With ICon

.Caption = "Up"

.FaceId = 132

.TooltipText = "上一页"

.OnAction = "UpPage"

.Enabled = False

End With

For I = 1 To 20

Set ICon = IBar.Controls.Add(Type:=msoControlButton)

With ICon

If I = 1 Then

.BeginGroup = True

End If

.FaceId = I

.TooltipText = "Id：" & I

End With

Set ICon = IBar.Controls.Add(Type:=msoControlButton)

With ICon

.Caption = "Down"

.BeginGroup = True

.FaceId = 133

.TooltipText = "下一页"

.OnAction = "DownPage"

End With

Set ICom = IBar.Controls.Add(Type:=msoControlComboBox)

With ICom

.Caption = "LNum"

.BeginGroup = True

.TooltipText = "每行图标数"

.OnAction = "LineNum"

.Width = 40

.Text = 20

For I = 1 To 10

.AddItem I * 5

End With

Set ICon = IBar.Controls.Add(Type:=msoControlButton)

With ICon

.Caption = "GId"

.FaceId = 59

.TooltipText = "给定FaceId值显示"

.OnAction = "GetID"

End With

Set ICon = IBar.Controls.Add(Type:=msoControlButton)

With ICon

.Caption = "GPg"

.FaceId = 159

.TooltipText = "显示第N页"

.OnAction = "GetPage"

End With

Set ICon = IBar.Controls.Add(Type:=msoControlButton)

With ICon

.Caption = "All"

.FaceId = 682

.TooltipText = "列出所有FaceId"

.OnAction = "ShowAll"

End With

Set ICon = IBar.Controls.Add(Type:=msoControlButton)

With ICon

.BeginGroup = True

.FaceId = 49

.TooltipText = "关于"

.OnAction = "About"

End With

Error:

End Sub

'删除工具栏

Sub BarDel()

On Error GoTo Error

CommandBars("IconId").Delete

Error:

End Sub

因为完整的代码较长，而且其它内容和这一贴无关，如果有兴趣的话，大家可以到本站中下载完整的加载宏文件，内置图标。

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/19.html

自定义Excel右键菜单-自定义Excel(15)

前面说过了自定义菜单与工具栏，如果大家利用好了，就可以很方便地让别人使用你编辑好的功能了。而这一贴要讲的，利用右键的菜单，让调用功能更为方便。

当我们使用右键时，Excel相对应都会有一些功能在右键的菜单中出现，比如右击单元格时有设定单元格的功能，右击行号与列标时，有设定行高与列宽的功能，那么，我们也可以相应在我们需要的时候，将功能将入右键的菜单中，方便调用，比如下面说的自定义宏——合并复制选择单元格的内容，即可以加入到在右击单元格时产生的右键菜单中。

其实这些菜单的使用方法和前面将的菜单与工具栏是类似的，工具栏对应的是CommandBars对象，菜单对应的是CommandBarControl对象，而CommandBarControl 对象中又分有三种——ComandBarButton(按钮控件)、CommandBarComboBox(组合框控件)以及这贴说的CommandBarPopup（弹出式控件），下面给出一段程序，在表格中列出全部的弹出式控件的名称及项目等内容。

Sub ListPopups()

Dim ctl As CommandBarControl

Dim cb As CommandBar

Dim intRow As Integer 'Tracks row in worksheet

'下面一行是检查当前工作表是否没有内容

If Not IsEmptyWorksheet(ActiveSheet) Then Exit Sub

On Error Resume Next

Application.ScreenUpdating = False

Cells(1, 1).Value = "CommandBar"

Cells(1, 2).Value = "Control"

Cells(1, 3).Value = "FaceID"

Cells(1, 4).Value = "ID"

Range("A1:D1").Font.Bold = True

intRow = 2

For Each cb In CommandBars

Application.StatusBar = "正在处理控制... " & cb.Name

'Only list command bar if type is Popup

If cb.Type = msoBarTypePopup Then

Cells(intRow, 1).Value = cb.Name

intRow = intRow + 1

'List controls on command bar

For Each ctl In cb.Controls

Cells(intRow, 2).Value = ctl.Caption

ctl.CopyFace

If Err.Number = 0 Then

ActiveSheet.Paste Cells(intRow, 3)

Cells(intRow, 3).Value = ctl.FaceId

End If

Cells(intRow, 4).Value = ctl.Id

Err.Clear

intRow = intRow + 1

Next ctl

End If

Next cb

Range("A:B").EntireColumn.AutoFit

Application.StatusBar = False

End Sub

'检查当前工作表是否有内容的函数

Function IsEmptyWorksheet(sht As Object) As Boolean

If TypeName(sht) = "Worksheet" Then

If WorksheetFunction.CountA(sht.UsedRange) = 0 Then

IsEmptyWorksheet = True

Exit Function

End If

MsgBox "请生成一个空的工作表！", vbCritical, _

"Warning"

End Function

从上面的程序可以让我们了解各种情况下的弹出菜单，只要通过名称及其相应的功能，我们就可以和现实中的操作对比，来获得需要的弹出菜单名称，比如单元格——Cell，行——Row等。之后我们就可以将自定义的项目加入对应的菜单中了。以下是我现实合并复复增减菜单项目的代码，其余代码略过：

Sub Menu_Del()

Dim N

N = Application.CommandBars("Cell").Controls.Count

For I = 1 To N

'当发现右键菜单中有"合并复制(&A)"项时将其删除

If Application.CommandBars("Cell").Controls(I).Caption = "合并复制(&A)" Then

Application.CommandBars("Cell").Controls(I).Delete

'下面这句是重置菜单，但个人认为还是用上面的方法比较好

'Application.CommandBars("cell").Reset

End If

End Sub

Sub Menu_Add()

Dim N, I, Cmb As CommandBarControl

N = Application.CommandBars("Cell").Controls.Count

For I = 1 To N

If Application.CommandBars("Cell").Controls(I).Caption = "合并复制(&A)" Then

Exit Sub

End If

Set Cmb = Application.CommandBars("cell").Controls.Add(Type:=msoControlButton)

With Cmb

.BeginGroup = True

.Caption = "合并复制(&A)"

.OnAction = "UnionCopy"

.FaceId = 159

End With

End Sub

以上两个程序的实例，请到我本站中的自定义宏项里下载——内置菜单与合并复制。

到此贴，自定义的内容已基本完成，而下面的自定义功能只是让大家多感受一些编程的魅力——只有想不到，没有做不到，而下面的功能的具体实现方法我也不是能给大家解释得很清楚，因为大多是基于类模块与API的应用，我也只能将相关的原代码贴出来，与大家分享！

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/20.html

前面我们已说明的怎么我们的加载宏自动生成一些菜单来调用我们编辑的功能，而接下来，我们还要进一步添加一个功能，即用快捷键来调用宏。

用来Excel的朋友都或多或少使用过快捷键吧，比如保存Ctrl+S，那怎么给我们的宏也加上快捷键呢，其实也很简单，只要在文件打开是用Application.OnKey定义我们的快捷键即可，下面是OnKey方法在Excel帮助中的内容：

当按特定键或特定的组合键时运行指定的过程。

expression.OnKey(Key, Procedure)

expression 必需。该表达式返回一个 Application 对象。

Key String 类型，必需。用于表示要按的键的字符串。

Procedure Variant 类型，可选。表示要运行的过程名称的字符串。如果 Procedure 参数为空文本 ("")，则按 Key 时不发生任何操作。OnKey 方式将更改击键在 Microsoft Excel 中产生的正常结果。如果省略 Procedure 参数，则 Key 产生 Microsoft Excel 中的正常结果，同时清除先前使用 OnKey 方法所做的特殊击键设置。

说明

Key 参数可指定任何与 Alt、Ctrl 或 Shift 组合使用的键，还可以指定这些键的任何组合。每一个键可由一个或多个字符表示，比如 "a" 表示字符 a，或者 "{ENTER}" 表示 Enter。

若要指定按对应的键（例如 Enter 或 Tab）时的非显示字符，请使用下表所列出的代码。表中的每一代码代表键盘上的一个对应键。

键代码

{BACKSPACE} or {BS}——Backspace

{BREAK}——Break

Caps Lock——{CAPSLOCK}

{CLEAR}——Clear

Delete 或 Del——{DELETE} 或 {DEL}

End——{END}

~（波形符）——Enter

Enter（数字小键盘）——{ENTER}

{ESCAPE} 或 {ESC}——Esc

{F1} 到 {F15}——F1 到 F15

{HELP}——Help

Home——{HOME}

{INSERT}——Ins

Num Lock——{NUMLOCK}

Page Down——{PGDN}

{PGUP}——Page Up

{RETURN}——Return

{SCROLLLOCK}——Scroll Lock

Tab——{TAB}

向上键——{UP}

{DOWN}——向下键

{RIGHT}——向右键

向左键——{LEFT}

还可指定与 Shift 和/或 Ctrl 和/或 Alt 组合使用的键。若要指定与其他键组合使用的键，可使用下表。

要组合的键在键代码之前添加

Shift——+（加号）

Ctrl——^（插入符号）

Alt——%（百分号）

若为特定字符指定处理过程（如 +、^、% 等等），可将此字符用圆括号括起。有关详细信息，请参阅示例。

示例

本示例为 Ctrl+ 加号分配“InsertProc”过程，并为 Shift+Ctrl+ 向右键分配“SpecialPrintProc”过程。

Application.OnKey "^{+}", "InsertProc"

Application.OnKey "+^{RIGHT}", "SpecialPrintProc"

本示例将 Shift+Ctrl+ 向右键重新设为正常的含义。

Application.OnKey "+^{RIGHT}"

本示例将 Shift+Ctrl+ 向右键设为不发生任何操作。

Application.OnKey "+^{RIGHT}", ""

这样，我们调用宏是不是又方便了不少，还有，要注意的一点是，在关闭加载宏时，要记得将快捷键还原哦。

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/21.html

说真的，类和类模块我也是接触得不多，不久，应用也很少，对这方面的了解也很少，这里只能将我所理解的这一点点，和大家一请交流：

什么是类：将用户定义类型和过程组织在一起即是类，类是一个模板，对象是由它而创建的。

什么是类模块：含有类定义的模块，包括其属性和方法的定义。

怎么建立类模块：建立类模块的方法和建立模块的方法是一样的，只是选择建立的项目是类模块。

上面就是现在我对类模块的了解，不多，甚至自己也有很多不理解的地方，在类模块的使用方面，记忆里曾经在学VB时编一个贪吃小蛇时，用过类来实现队列（先进先出的一种数据结构），之后就仅仅用类创建一个Application 对象来即时监控Excel，下面就将这个应用的代码列给大家。

还记得在自定义菜单中定义的名为“Excel各页名”的宏吧，当没有可见的工作簿时，如果运行此宏就会出错，因为无法写入内容。上贴我们已给这个宏加入了快捷键的功能，使它更方便的使用，而这一贴我们就要利用类模块，让它更完美。

其实只要在这个宏的代码里加入检验的代码，即可以不会出错，但实际，我们还是运行了这个宏。细心的朋友有没有发现，当Excel无可见工作簿时，一些工具栏和菜单里的项目是不可使用的，那我们今天也来实现这个功能。

首先要建立一个类模块，名为MenuClass，注意，这个名称对应着后面的代码，如果改动的话，后面也需要进行相应的修改，类模块的代码如下：

'定义一个 Application 对象

Public WithEvents xlApp As Excel.Application

'定义一个按钮控件属性，用来对应相应的菜单项

Public XMenu As CommandBarButton

'定义一个字符串，用来保存相应的快捷键

Public XOnkey As String

'定义一个字符串，用来保存相应的宏名称

Public XSubName As String

'当文件新建打开关闭隐藏时都有可能使可见的工作簿数量变动

'但我们只要监控WorkbookActivate（激活任一工作簿）事件与

'WorkbookDeactivate（工作簿由活动转为非活动状态）事件即可。

'下面即是相对应的代码：

Private Sub xlApp_WorkbookActivate(ByVal Wb As Workbook)

If XMenu Is Nothing Then

Exit Sub

End If

If Wb.Windows(1).Visible Then

XMenu.Enabled = True

Application.Onkey XOnkey, XSubName

End If

End Sub

Private Sub xlApp_WorkbookDeactivate(ByVal Wb As Workbook)

Dim XWindow As Window

If XMenu Is Nothing Then

Exit Sub

End If

For Each XWindow In xlApp.Windows

If XWindow.Caption <> Wb.Name And XWindow.Visible Then

XMenu.Enabled = True

Application.Onkey XOnkey, XSubName

Exit Sub

End If

XMenu.Enabled = False

Application.Onkey XOnkey

End Sub

完成类模块的代码后，我们即可以使用这个类。下面是在mian模块中的一些相应的代码：

'定义一个我们自定义的类

Dim EMenu As New MenuClass

Dim AName, MName(2, 1), DelMenu(2) As Boolean

Sub auto_close()

Dim MyMenu As CommandBarPopup

Dim MyBtn As CommandBarButton

Dim i As Byte

Application.Onkey "^%a"

Set EMenu.XMenu = Nothing

Set MyMenu = CommandBars("Worksheet Menu Bar").Controls(AName)

For i = 0 To UBound(MName)

If DelMenu(i) Then

Set MyBtn = MyMenu.CommandBar.Controls(MName(i, 0))

If MyBtn Is Nothing Then

Error = True

Else

MyBtn.Delete

End If

If MyMenu.CommandBar.Controls.Count = 0 Then

MyMenu.Delete

Else

For i = 1 To MyMenu.CommandBar.Controls.Count

Set MyBtn = MyMenu.Controls(i)

MyBtn.FaceId = MyBtn.Index + 79

End If

If Err.Number > 0 Then

MsgBox "文件关闭时卸载菜单发生异常！" & vbCrLf & _

"自动生成的菜单可能已被卸载！" & vbCrLf & _

"或生成的菜单没有完全被卸载！", vbExclamation, "错误"

End If

End Sub

Sub auto_Open()

Dim MyMenu As CommandBarPopup

Dim MyBtn As CommandBarButton

Dim i As Byte

Dim XT As String

On Error Resume Next

AName = "自定义(&Z)" '菜单名称

MName(0, 0) = "百度Excel吧(&A)" '菜单项名称

MName(0, 1) = "BaiDuExcelBa" '指定宏名称

MName(1, 0) = "Excel吧主页(&B)" '菜单项名称

MName(1, 1) = "ExcelBaZy" '指定宏名称

MName(2, 0) = "Excel各页名(&C)" '菜单项名称

MName(2, 1) = "Excel各页名" '指定宏名称

Set MyMenu = CommandBars("Worksheet Menu Bar").Controls(AName)

If MyMenu Is Nothing Then

Set MyMenu = CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)

MyMenu.Caption = AName

End If

For i = 0 To UBound(MName)

Set MyBtn = MyMenu.CommandBar.Controls(MName(i, 0))

If MyBtn Is Nothing Then

DelMenu(i) = True

Set MyBtn = MyMenu.CommandBar.Controls.Add(Type:=msoControlButton)

With MyBtn

.Style = msoButtonIconAndCaption

.FaceId = 79 + MyBtn.Index

.Caption = MName(i, 0)

.OnAction = MName(i, 1)

End With

Else

DelMenu(i) = False

XT = XT & vbCrLf & MName(i, 0)

End If

Set MyBtn = Nothing

'初始化相关的属性

Set EMenu.XMenu = MyMenu.CommandBar.Controls(3)

EMenu.XMenu.Enabled = False

For Each XWindow In Application.Windows

If XWindow.Visible Then

EMenu.XMenu.Enabled = True

Exit For

End If

Set EMenu.xlApp = Application

EMenu.XOnkey = "^%a"

EMenu.XSubName = "Excel各页名"

Application.Onkey EMenu.XOnkey, EMenu.XSubName

If Len(XT) > 0 Then

MsgBox "已存在菜单名：" & XT & vbCrLf & "不能再被加载！", vbExclamation, "错误"

End If

End Sub

也许大家看完了之后还不是很了解，但我能力也有限，目前只能给大家解释到此，等以后对此有更深的理解之后，还会和大家一起分享。大家可以从本站里下载完整的代码——自定义宏/Excel各页名。

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/22.html

什么是Windows API? Windows 这个多作业系统除了协调应用程式的执行、分配内存、管理系统资源…之外，她同时也是一个很大的服务中心，调用这个服务中心的各种服务(每一种服务就是一个函数)，可以帮应用程式达到开启视窗、描绘图形、使用周边设备…等目的，由於这些函数服务的对象是应用程式(Application)，所以便称之为 Application Programming Interface，简称 API 函数。WIN32 API也就是MicrosoftWindows 32位平台的应用程序编程接口。凡是在 Windows 工作环境底下执行的应用程式，都可以调用Windows API。

Visual Basic以友好易学的可视化开发环境闻名于世，成为人们学习计算机编程的首选语言(以前是，现在不吃香了，而且VBA也开始转向.net了，又要坚苦学习了*~_~*)。目前，还有很多人使用着Visual Basic语言。如果您想在这茫茫众生中出类拔萃，那么您就不得不学习API编程。不懂API，那可成不了高手（所以我不是*~_~*)。API说到底就是一系列的底层函数，是系统提供给用户用于进入操作系统核心，进行高级编程的途径。通过在Visual Basic应用程序中声明外部过程就能够访问Windows API(以及其它的外部DLLs)。在声明了过程之后，调用它的方法与调用Visual Basic自己的过程相同。

在前面我们已说过什么是VBA？VBA是Visual Basic for Applications 的简称，Visual Basic（VB）在office的应用版。所以在VBA里也能调用API。

实际上如果我们要开发出更灵活、更实用、更具效率的应用程序，必然要涉及到直接使用API函数，虽然类库和控件使应用程序的开发简单的多，但它们只提供WINDOWS的一般功能，对于比较复杂和特殊的功能来说，使用类库和控件是非常难以实现的，这时就需要采用API函数来实现。

　　这也是API函数使用的场合，所以我们对待API函数不必刻意去研究每一个函数的用法，那也是不现实的(能用得到的API函数有几千个呢)。正如某位大虾所说：API不要去学，在需要的时候去查API帮助就足够了。但是，许多API函数令人难以理解，易于误用，还会导致出错(调用API时稍有不慎就可能导致API编程错误，出现难于捕获或间歇性错误，甚至出现程序崩溃，乃至死机*~_~*），这一切都阻碍了它的推广。想快速掌握API函数用法，最好就是通过对API函数的分类，结合一些有趣的实例，应该可以达到快速掌握的目的。

前面的内容中，有讲到API帮助，大家可以从网上搜索获得，如果有MSDN光盘的话，里面其实就很全了，而关于API的实例网上也很多，毕竟VB目前还是一个使用很广的语言，大家可以自行在网上搜索。而下面的贴子，就是我收集的几个VBA利用API实现一些自定义Excel项的内容。难懂，但很有趣，正如我之前所说的，没有办不到的，只有想不到的……

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/23.html

这一贴将给出第一个利用API的例子，来修改Excel的图标。

修改标题很简单，通过Application.Caption就能获得和设定，我们将修改后的标题保存在本身工作簿和第一个工作表的A2格中，让下一次给够自行更改；而重置只要改回“Microsoft Excel”即可。代码如下：

’设定标题

Sub CaptionSet()

Dim TStr As String

TStr = InputBox("请输入自定义标题：", "提示", ThisWorkbook.Sheets(1).Range("A2").Value)

If Len(TStr) > 0 Then

Application.Caption = TStr

ThisWorkbook.Sheets(1).Range("A2").Value = TStr

ThisWorkbook.Save

End If

End Sub

’重置标题

Sub CaptionReSet()

Application.Caption = "Microsoft Excel"

End Sub

而修改Excel的图标就要用到API了，一共要用到五个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 wParam As 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

FindWindow：寻找窗口列表中第一个符合指定条件的顶级窗口

DrawMenuBar：为指定的窗口重画菜单

SetFocus：将输入焦点设到指定的窗口

SendMessage：调用一个窗口的窗口函数，将一条消息发给那个窗口

ExtractIcon：判断一个可执行文件或DLL中是否有图标存在，并将其提取出来

这样说明上面的五个API函数可能大家无法理解，但我也只能解释到此，API的学习我也刚刚开始：（

下面是修改与重置图标的代码，如下：

’设定图标的函数

Function SetIcon(IconPath As String)

Dim IStyle As Long, hIcon As Long

hIcon = ExtractIcon(0, IconPath, 0) ’获得指定文件的第一个图标

SendMessage hWndForm, WM_SETICON, True, hIcon ’刷新图标

SendMessage hWndForm, WM_SETICON, False, hIcon ’刷新图标

DrawMenuBar hWndForm ’重画菜单

SetFocus hWndForm ’指定焦点

End Function

’获得Excel句标的函数

Function hWndForm() As Long

hWndForm = FindWindow(vbNullString, Application.Caption)

End Function

’设定图标

Sub IconSet()

Dim TStr As String

TStr = Application.GetOpenFilename("所有图标文件,*.ico;*.exe")

If TStr <> "False" And Dir(TStr) <> "" Then

ThisWorkbook.Sheets(1).Range("A1").Value = TStr

SetIcon TStr

ThisWorkbook.Save

End If

End Sub

’重置图标

Sub IconReSet()

SetIcon Application.Path & "\Excel.exe"

End Sub

主要功能代码就完成了，我们还可以利用我们前面说过的，加入菜单调用（我主页的加载宏是加在主菜单的视图项中），这样就可以完成我们全部的功能了。点击下载完整代码。

看看Excel左上角不再是那个熟悉的绿X，而标题是“XXX专用Excel”，你是否有兴趣再继续我们的自定义之路？

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/24.html

API的用处不是一时半会就可以说完了，但例子还是要一个个给，现在给出第二个利用API的例子，在Excel的状态栏中显示自定义的进度条。

'//此模块创建了一个显示在状态栏的自定义进度条，并可对状态栏的文字进行设置

'//——以下声明API函数——

'//创建文字函数，其中fCharacterSet：字符集;134为GB2312

Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal fHeight As Long, ByVal fWidth As Long, ByVal fEscapement As Long, ByVal fOrientation As Long, ByVal fWeight As Long, ByVal fItalic As Long, ByVal fUnderline As Long, ByVal fStrikeout As Long, ByVal fCharacterSet As Long, ByVal fPrecision As Long, ByVal fClipping As Long, ByVal fQuality As Long, ByVal fPitchAndFamily As Long, ByVal fName As String) As Long

'//取得窗体设备环境函数

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

'//设置环境内容，此处为文字

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

'//删除创建的环境内容

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'//释放设备环境

Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

'//该函数创建一个具有扩展风格的重叠式窗口、弹出式窗口或子窗口

Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long

'//破坏创建的窗口

Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

'//设置一个窗口为另一窗口的子窗口

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

'//视情况向窗体发送不同的信息

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'//查找窗口句柄

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

'//查找一个窗口中子窗口的句柄

Private 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 Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

'//设置文本颜色

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

'//取得系统色

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

'//取得窗体客户区坐标

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

'//——以下定义常量及类型——

Private Const WS_VISIBLE = &H10000000 '可见

Private Const WS_CHILD = &H40000000 '子窗口

Private Const WS_BORDER = &H800000 '单边框

Private Const PBS_STANDARD = &H0 '标准

Private Const PBS_SMOOTH = &H1 '平滑

Private Const CCM_FIRST = &H2000&

Private Const WM_USER = &H400

Private Const PBM_SETBKCOLOR = (CCM_FIRST + 1) '设置进度条背景色

Private Const PBM_SETPOS = (WM_USER + 2) '设置进度条状态

Private Const PBM_SETBARCOLOR = (WM_USER + 9) '设置进度条颜色

Private Const COLOR_BTNFACE = 15 '系统按纽背景色

Private Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

'//进度条显示时的样式

Enum PBType

P_STANDARD = WS_VISIBLE Or WS_CHILD Or WS_BORDER Or PBS_STANDARD '标准样式

P_SMOOTH = WS_VISIBLE Or WS_CHILD Or WS_BORDER Or PBS_SMOOTH '平滑式

End Enum

'// 文字的字体粗细需在0到1000之间，例如，400代表普通，700代表粗体，而0则表示默认。

Enum FnWeight

FW_DONTCARE = 0

FW_THIN = 100

FW_EXTRALIGHT = 200

FW_ULTRALIGHT = 200

FW_LIGHT = 300

FW_NORMAL = 400

FW_REGULAR = 400

FW_MEDIUM = 500

FW_SEMIBOLD = 600

FW_DEMIBOLD = 600

FW_BOLD = 700

FW_EXTRABOLD = 800

FW_ULTRABOLD = 800

FW_HEAVY = 900

FW_BLACK = 900

End Enum

'// 主过程

'//参数如下；

'//FontHeight:文字高度,FontWeight:文字粗细,FontColor:文字颜色,Italic:斜体,lngPBType:进度条类型,MaxVlue:最大值,StopValue:停止值,Prompt:状态栏字符串。

Sub StatusBarMsg(FontHeight As Long, FontWeight As FnWeight, FontColor As Long, Italic As Boolean, lngPBType As PBType, MaxVlue As Long, StopValue As Long, Prompt As String)

Dim hwndStatusbar As Long '状态栏句柄

Dim PbHwnd As Long '创建的进度条

Dim XlStaBarRect As RECT '用于装载状态栏区域

Dim xlMain As Long 'EXCEL主窗口句柄

Dim hDcStatusBar As Long '状态栏设备环境

Dim hFont As Long, hFontOld As Long '创建的文字及原文字信息

Dim oldStatusBar As Boolean '原状态栏状态

Dim I As Long, iVal As String

Dim StrLen As Integer '状态栏文本长度

Dim GetBarRECT As Long

StrLen = Len(Prompt) * Abs(FontHeight) + 30

'// 取得EXCEL主窗口的句柄。

xlMain = FindWindow("XLMAIN", vbNullString) 'Excel2002及以后版本可以直接用Application.hWnd 来取得Excel主窗口的句柄

'// 取得状态栏的句柄。状态栏类名："EXCEL4"

hwndStatusbar = FindWindowEx(xlMain, 0, "EXCEL4", vbNullString)

'//取得状态栏的客户区坐标

GetBarRECT = GetClientRect(hwndStatusbar, XlStaBarRect)

'// 取得状态栏的场景

hDcStatusBar = GetDC(hwndStatusbar)

'//创建一种将用于状态栏的文字, 注意: 文字名称的长度必修小于32 ' "新宋体"为自己给定的文字名，可以自行更改

hFont = CreateFont(FontHeight, 0, 0, 0, FontWeight, Italic, 0, 0, 134, 0, 0, 0, 0, "新宋体")

'// 首先设置新字体并保存原来的字体！

hFontOld = SelectObject(hDcStatusBar, hFont)

'// 保存原状态栏状态

oldStatusBar = Application.DisplayStatusBar

Application.DisplayStatusBar = True

'// 创建进度条

PbHwnd = CreateWindowEX(0, "msctls_progress32", "", lngPBType, StrLen, XlStaBarRect.Top + 1, 198, _

XlStaBarRect.Bottom - 2, hwndStatusbar, 0, 0, 0)

'//将进度条设为状态栏的子窗口

SetParent PbHwnd, hwndStatusbar

'// 进度条颜色，颜色可以自行设置

SendMessage PbHwnd, PBM_SETBARCOLOR, 0&, ByVal 16711680 '蓝色

'// 进度条背景色，颜色可以自行设置

SendMessage PbHwnd, PBM_SETBKCOLOR, 0&, ByVal 16777215 '白色

'//状态栏背景色，这里用的是按纽背景色

Call SetBkColor(hDcStatusBar, GetSysColor(COLOR_BTNFACE))

'//文字颜色，即状态栏前景色

Call SetTextColor(hDcStatusBar, FontColor)

'//设置状态栏文字

Application.StatusBar = Prompt

For I = 1 To MaxVlue

iVal = I / MaxVlue * 100

If I = StopValue Then

'//保存工作薄

'ActiveWorkbook.Save

Call SetBkColor(hDcStatusBar, GetSysColor(COLOR_BTNFACE))

Call SetTextColor(hDcStatusBar, FontColor)

Application.StatusBar = Prompt

End If

'//向进度条发送消息，以更改进度条的状态

SendMessage PbHwnd, PBM_SETPOS, ByVal iVal, 0&

Next I

'// 清除进度条

DestroyWindow PbHwnd

'// 恢复原来状态栏的字体

SelectObject hDcStatusBar, hFontOld

'//释放状态栏的设备场景

ReleaseDC hwndStatusbar, hDcStatusBar

'//恢复原状态栏状态

Application.StatusBar = False

Application.DisplayStatusBar = oldStatusBar

End Sub

'//此为工作表中按钮调用程序

Sub SaveWorkbook()

Call StatusBarMsg(-12, FW_BOLD, 255, False, P_SMOOTH, 800000, 800000, "正在保存当前工作薄，请稍候……")

End Sub

下面是ThisWorkbook的代码

'//重置自定义设定

Private Sub Workbook_BeforeClose(Cancel As Boolean)

With Application

.CommandBars("Worksheet Menu Bar").Controls("文件(&F)").Controls("保存(&S)").Reset

.CommandBars("Standard").Controls("保存(&S)").Reset

.OnKey "^s"

End With

End Sub

'//将菜单,工具栏和快捷键(Ctrl+S)上的保存菜单重设为执行自己的过程

Private Sub Workbook_Open()

With Application

.CommandBars("Worksheet Menu Bar").Controls("文件(&F)").Controls("保存(&S)").OnAction = "SaveWorkbook"

.CommandBars("Standard").Controls("保存(&S)").OnAction = "SaveWorkbook"

.OnKey "^s", "SaveWorkbook"

End With

End Sub

这样你就自定义好了进度条，可惜的是这个进度条还不算完善，它不能自行根据保存文件所需要的时间动态变化进度条的演示时间，还有，这时按菜单，工具栏与快捷键Ctrl+S其实都没有保存文件,我把保存文件的这行代码变成备注了！！请注意！点击下载完全代码。

这是第三个利用API的例子，其中应用到不少API函数，还要用到NOTIFYICONDATA这个数据结构。

系统托盘，即桌面最右下角显示时间的地方，现在的很多程序都会在这个地方生成一个图标，而我们这一贴就是要让Excel最小化后到系统托盘。

首先，最小化在这里其实是工作簿最小化，而不是Excel的主程序，因为这里是用类来监控Excel的最小化事件，而类只能监控到工作簿级的事件，因此利用API禁用了Excel主程序的最小化按钮，下面是这个类WorkBookClass的代码，这里我们只要监控工作簿的WindowResize事件：

Public WithEvents xlbookapp As Excel.Application

Private Sub xlbookapp_WindowResize(ByVal Wb As Workbook, ByVal Wn As Window)

If Wn.WindowState = xlMinimized Then

hideHwnd

End If

End Sub

按下来是加载宏加载时在工作簿的右键菜单中加入隐藏这个功能项，其增加与删除的代码如下：

Sub Menu_Del()

Dim N, i

N = Application.CommandBars("Document").Controls.Count

For i = 1 To N

'当发现右键菜单中有"隐藏(&H)"项时将其删除

If Application.CommandBars("Document").Controls(i).Caption = "隐藏(&H)" Then

Application.CommandBars("Document").Controls(i).Delete

Exit Sub

'下面这句是重置菜单，但个人认为还是用上面的方法比较好

'Application.CommandBars("Document").Reset

End If

End Sub

Sub Menu_Add()

Dim N, i, Cmb As CommandBarControl

N = Application.CommandBars("Document").Controls.Count

For i = 1 To N

If Application.CommandBars("Document").Controls(i).Caption = "隐藏(&H)" Then

Exit Sub

End If

Set Cmb = Application.CommandBars("Document").Controls.Add(Type:=msoControlButton, before:=N)

With Cmb

.BeginGroup = True

.Caption = "隐藏(&H)"

.OnAction = "hideHwnd"

.FaceId = 597

.Visible = True

End With

End Sub

再下来就中API的定义，这里我们一共要用到10个API函数：

从指定窗口的结构中取得信息，这里用来获得Excel主窗口的窗口样式

Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

调查窗口标题文字或控件内容的长短

Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long

取得一个窗体的标题（caption）文字

Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

控制窗口的可见性

Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

寻找窗口列表中第一个符合指定条件的顶级窗口

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

在窗口结构中为指定的窗口设置信息

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

判断一个可执行文件或DLL中是否有图标存在，并将其提取出来，这里用来取得Excel的图标

Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

使用系统托盘的API函数，这个贴子的主功能的实现函数

Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

为指定的窗口重画菜单

Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

判断窗口是否可见

Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long

此外还要定义一个数据结构和一些常量：

Public Type NOTIFYICONDATA

cbSize As Long

hwnd As Long

uID As Long

uFlags As Long

uCallbackMessage As Long

HIcon As Long

szTip As String * 64

End Type

Public Const WM_LBUTTONUP = &H202

Public Const GWL_WNDPROC = (-4)

Public Const WM_USER = &H400

Public Const WM_NOTIFYICON = WM_USER + &H100

Public Const WM_SYSCOMMAND = &H112

Public Const SC_RESTORE = &HF120&

Public Const NIM_ADD = &H0

Public Const NIM_DELETE = &H2

Public Const NIF_MESSAGE = &H1

Public Const NIF_ICON = &H2

Public Const NIF_TIP = &H4

Public Const WM_PAINT = &HF

Public Const SW_HIDE = 0

Public Const SW_SHOW = 5

Public Const GWL_STYLE = (-16)

Public Const WS_MINIMIZEBOX = &H20000

之后是全局变量

Public XlbHide As New WorkBookClass

Dim myData As NOTIFYICONDATA

Dim VBEV As Boolean

Dim App_Cap As String

Dim XWin As XlWindowState

Public xlMainHwnd As Long

Public OldWindowProc As Long

下面是主程序：

隐藏时添加图标的代码：

Public Sub hideHwnd()

Dim HIcon

HIcon = ExtractIcon(0, Application.Path & "\Excel.exe", 0)

With myData

.cbSize = Len(myData)

.hwnd = xlMainHwnd

.uID = 0

.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP

.uCallbackMessage = WM_NOTIFYICON

.HIcon = HIcon

.szTip = "Excel" & vbNullChar

End With

App_Cap = Application.Caption

xlMainHwnd = FindWindow(vbNullString, App_Cap)

OldWindowProc = SetWindowLong(xlMainHwnd, GWL_WNDPROC, AddressOf NewWindowProc)

Shell_NotifyIcon NIM_ADD, myData

XWin = ActiveWindow.WindowState

Application.Visible = False

If GetVBEVisible() Then

VBEV = True

HideVBE

Else

VBEV = False

End If

End Sub

响应图标点击时的代码

Public Function NewWindowProc(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

If msg = WM_NOTIFYICON Then

If lParam = WM_LBUTTONUP Then

If Application.Visible = False Then

If VBEV Then

ShowVBE

End If

Application.Visible = True

ActiveWindow.WindowState = xlMaximized

Application.Visible = True

myData.uFlags = 0

Shell_NotifyIcon NIM_DELETE, myData

SetWindowLong xlMainHwnd, GWL_WNDPROC, OldWindowProc

DrawMenuBar xlMainHwnd

If XWin = xlNormal Then

ActiveWindow.WindowState = XWin

End If

Application.Caption = App_Cap

Exit Function

End If

End Function

显示VBE窗口的代码，本来利用Application.VBE.MainWindow.Visible可以显示和隐藏VBE窗口，但会受到宏的安全性限制，因此这里也利用API来完成。

Sub ShowVBE()

Dim a As Long

a = FindWindow(vbNullString, GetVBECaption())

ShowWindow a, SW_SHOW

End Sub

隐藏VBE窗口代码：

Sub HideVBE()

Dim a As Long

a = FindWindow(vbNullString, GetVBECaption())

ShowWindow a, SW_HIDE

End Sub

获得VBE的标题，同样可以利用Application.VBE.MainWindow.Caption获得，但理由同上

Function GetVBECaption() As String

Dim a$, i

GetVBECaption = ""

For i = 1 To 10000

a$ = GetWindowTitle(i)

If a$ Like "Microsoft Visual Basic - *" Then

GetVBECaption = a$

Exit Function

End If

End Function

判断VBE窗口的可见壮态

Function GetVBEVisible() As Boolean

Dim a As Long

If Len(GetVBECaption()) = 0 Then

GetVBEVisible = False

Else

a = FindWindow(vbNullString, GetVBECaption())

GetVBEVisible = IsWindowVisible(a)

End If

End Function

获得所有进程的标题

Function GetWindowTitle(ByVal hwnd As Long) As String

On Error Resume Next

Dim l As Long, s As String

l = GetWindowTextLength(hwnd)

s = Space(l + 1)

GetWindowText hwnd, s, l + 1

GetWindowTitle = Left$(s, l)

End Function

最后是ThisWorkbook的代码

退出时还原最小化按钮及删除添加的菜单项

Private Sub Workbook_BeforeClose(Cancel As Boolean)

xlMainHwnd = FindWindow(vbNullString, Application.Caption)

IStyle = GetWindowLong(xlMainHwnd, GWL_STYLE) Or WS_MINIMIZEBOX

SetWindowLong xlMainHwnd, GWL_STYLE, IStyle

DrawMenuBar xlMainHwnd

Menu_Del

End Sub

加载时初始化类、禁用最小化按钮与添加相应的菜单项

Private Sub Workbook_Open()

Set XlbHide.xlbookapp = Application

xlMainHwnd = FindWindow(vbNullString, Application.Caption)

IStyle = GetWindowLong(xlMainHwnd, GWL_STYLE) And Not WS_MINIMIZEBOX

SetWindowLong xlMainHwnd, GWL_STYLE, IStyle

DrawMenuBar xlMainHwnd

Menu_Add

End Sub

至此，目前收集的API之自定义实例已完毕，不知道大家还有没有其它好的想法或相关的实例，也贴出来分享*~_~*，点击下载完整文件。

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/26.html

Cursor 属性

返回或设置 Microsoft Excel 中鼠标指针的形状。XlMousePointer 类型，可读写。

XlMousePointer 可为以下 XlMousePointer 常量之一。

xlDefault 默认指针。

xlIBeam I 型指针。

xlNorthwestArrow 西北向箭头指针。

xlWait 沙漏型指针。

expression.Cursor

expression 必需。该表达式返回“应用于”列表中的对象之一。

说明

当宏停止运行时，Cursor 属性不会自动重设。在宏停止运行前，应将指针重设为 xlDefault。

示例

本示例将鼠标指针形状更改为 I 形，稍停片刻，然后将其重新变为默认指针形状。

Sub ChangeCursor()

Application.Cursor = xlIBeam

For x = 1 To 1000

For y = 1 to 1000

Next y

Next x

Application.Cursor = xlDefault

End Sub

转载请注明:本文来自:Excel吧 (www.excelba.com) 详细出处参考：http://www.excelba.com/Art/Html/27.html

通过VBA自定义向Excel添加工具栏

通过VBA自定义向Excel添加工具栏

推荐内容

相关推荐

黑龙江卫生计生委2014上半年直属事业单位招聘进入面试人员名单

室内空气污染不只是甲醛污染如何除空气污染

百佳护士申报材料

长江航运公安局2014年度公务员录用面试人选递补公告

2019-2020年高中语文 11黛玉之死（第一课时）精品教案大纲人教版第六册

北大附中小升初历届点招试题100题汇总（详解答案）

播音主持社团活动计划

组合逻辑电路的设计

在2014年XXXX公司人力资源管理研讨会上的七点建议

色谱分析技术在黄岩供电局的应用

通过VBA自定义向Excel添加工具栏

推荐内容

相关推荐

黑龙江卫生计生委2014上半年直属事业单位招聘进入面试人员名单

室内空气污染不只是甲醛污染如何除空气污染

百佳护士 申报材料

长江航运公安局2014年度公务员录用面试人选递补公告

2019-2020年高中语文 11黛玉之死（第一课时）精品教案 大纲人教版第六册

北大附中小升初历届点招试题100题汇总（详解答案）

播音主持社团活动计划

组合逻辑电路的设计

在2014年XXXX公司人力资源管理研讨会上的七点建议

色谱分析技术在黄岩供电局的应用

百佳护士申报材料

2019-2020年高中语文 11黛玉之死（第一课时）精品教案大纲人教版第六册