2009年10月23日, 2:30 下午
Loading ...
在《RibbonX: Customizing the Office 2007 Ribbon》的第1章，介绍了一个在Excel 2003及以前版本中定制工具栏的很好的示例，现辑录于此，与大家分享。
首先，在VBE中，插入一个类模块，并命名为clsEvents，输入下面的代码：
'声明应用程序事件
Public WithEvents appXL As Application
Public WithEvents drop As Office.CommandBarComboBox
Private Sub appXL_SheetActivate(ByVal Sh As Object)
Dim ws As Worksheet
Dim Wb As Workbook
Dim i As Long
On Error GoTo Err_Handler
Set Wb = ActiveWorkbook
If Not Wb.Name = ThisWorkbook.Name Then Exit Sub
'初始化复选框
Set g_cmdbarcboBox = g_cmdBar.FindControl(Type:=msoControlDropdown, Tag:="MyList")
g_cmdbarcboBox.Clear
'添加复选框项目,即工作表名称
For Each ws In Sh.Parent.Sheets
g_cmdbarcboBox.AddItem ws.Name
Next
For i = 1 To g_cmdbarcboBox.ListCount
If g_cmdbarcboBox.List(i) = Sh.Name Then g_cmdbarcboBox.ListIndex = i: Exit For
Next
Call drop_Change(g_cmdbarcboBox)
Exit Sub
Err_Handler:
ErrHandle Err
End Sub
Private Sub appXL_WorkbookActivate(ByVal Wb As Workbook)
Set g_cmdbarcboBox = g_cmdBar.FindControl(Type:=msoControlDropdown, Tag:="MyList")
If Wb.Name = ThisWorkbook.Name Then
g_cmdbarcboBox.Enabled = True
appXL_SheetActivate Wb.ActiveSheet
Else:
Call deleleteControls
g_cmdbarcboBox.Enabled = False
End If
Exit Sub
Err_Handler:
ErrHandle Err
End Sub
Public Sub setDrop(box As Office.CommandBarComboBox)
'设置复选框对象
Set drop = box
End Sub
Private Sub drop_Change(ByVal Ctrl As Office.CommandBarComboBox)
'如果选择的复选框文本为工作表名称,则创建相应的菜单
Select Case UCase(Ctrl.Text)
Case "SUPPLIERS"
Call setMNUSUPPLIERS
Case "CUSTOMERS"
Call setMNUCUSTOMERS
Case "ACCOUNTS"
Call setMNUACCOUNTS
Case Else
Call deleleteControls
End Select
End Sub然后，添加标准模块，输入下面的代码：
'声明全局变量
Public Const gcstrCMDBARNAME As String = "DYNAMIC MENU"
Public Const gcstrMNUSUPPLIERS As String = "Suppliers"
Public Const gcstrMNUCUSTOMERS As String = "Customers"
Public Const gcstrMNUACCOUNTS As String = "Accounts"
Public g_cmdBar As CommandBar
Public g_cmdbarMenu As CommandBarPopup
Public g_cmdbarBtn As CommandBarButton
Public g_cmdbarcboBox As CommandBarComboBox
Public gcls_appExcel As New clsEvents
Public gcls_cboBox As New clsEvents
Sub wsBuildMenus()
Call wsDeleteMenus
On Error GoTo Err_Handler
'添加工具栏,并设置尺寸
Set g_cmdBar = CommandBars.Add(gcstrCMDBARNAME, msoBarFloating)
g_cmdBar.Width = 150
'添加复选框
Set g_cmdbarcboBox = g_cmdBar.Controls.Add(Type:=msoControlDropdown)
'设置复选框标签以便程序中识别
'设置复选框操作过程
With g_cmdbarcboBox
.Tag = "MyList"
.OnAction = "selectedSheet"
.Width = 150
End With
'添加帮助按钮
Set g_cmdbarBtn = g_cmdBar.Controls.Add(Type:=msoControlButton)
With g_cmdbarBtn
.Caption = "帮助"
.OnAction = "runHelp"
.Style = msoButtonIconAndCaption
.FaceId = 984
End With
'设置应用程序级事件并传递复选框对象
Set gcls_appExcel.appXL = Application
gcls_cboBox.setDrop g_cmdbarcboBox
With g_cmdBar
.Visible = True
.Protection = msoBarNoChangeDock + msoBarNoResize
End With
Exit Sub
Err_Handler:
ErrHandle Err
End Sub
'删除菜单工具栏
Sub wsDeleteMenus()
On Error Resume Next
Application.CommandBars(gcstrCMDBARNAME).Delete
Set g_cmdBar = Nothing
Set g_cmdbarMenu = Nothing
Set g_cmdbarBtn = Nothing
Set g_cmdbarcboBox = Nothing
Set gcls_appExcel = Nothing
Set gcls_cboBox = Nothing
End Sub
'删除工具栏中的菜单项
Sub deleleteControls()
On Error Resume Next
g_cmdBar.Controls(gcstrMNUACCOUNTS).Delete
g_cmdBar.Controls(gcstrMNUCUSTOMERS).Delete
g_cmdBar.Controls(gcstrMNUSUPPLIERS).Delete
End Sub
'设置复选框中选中项目后的操作,即激活与项目名称相同的工作表
Sub selectedSheet()
Dim g_cmdbarcboBox As CommandBarComboBox
On Error Resume Next
Set g_cmdbarcboBox = CommandBars.FindControl(Type:=msoControlDropdown, Tag:="MyList")
ActiveWorkbook.Sheets(g_cmdbarcboBox.Text).Activate
End Sub
'设置选择相应工作表后,出现在工具栏中的菜单
Sub setMNUACCOUNTS()
Call deleleteControls
On Error GoTo Err_Handler
Set g_cmdbarMenu = g_cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)
g_cmdbarMenu.Caption = gcstrMNUACCOUNTS
Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)
g_cmdbarBtn.Caption = "New Account"
Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)
g_cmdbarBtn.Caption = "Delete account"
Exit Sub
Err_Handler:
ErrHandle Err
End Sub
Sub setMNUSUPPLIERS()
Call deleleteControls
On Error GoTo Err_Handler
Set g_cmdbarMenu = g_cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)
g_cmdbarMenu.Caption = gcstrMNUSUPPLIERS
Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)
g_cmdbarBtn.Caption = "New Supplier"
Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)
g_cmdbarBtn.Caption = "Current data"
Exit Sub
Err_Handler:
ErrHandle Err
End Sub
Sub setMNUCUSTOMERS()
Call deleleteControls
On Error GoTo Err_Handler
Set g_cmdbarMenu = g_cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)
g_cmdbarMenu.Caption = gcstrMNUCUSTOMERS
Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)
g_cmdbarBtn.Caption = "New Customer"
Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)
g_cmdbarBtn.Caption = "Outstanding parts"
Exit Sub
Err_Handler:
ErrHandle Err
End Sub
Sub ErrHandle(ByVal objError As ErrObject)
MsgBox objError.Description, vbCritical, objError.Number
Call wsDeleteMenus
End Sub
Sub runHelp()
ActiveWorkbook.FollowHyperlink "http://www.excelperfect.com", NewWindow:=True, AddHistory:=True
End Sub最后，编写ThisWorkbook模块代码，以便在工作簿打开时执行创建工具栏的操作，在工作簿关闭时删除自定义工具栏。
Private Sub Workbook_Open()
Call wsBuildMenus
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call wsDeleteMenus
End Sub至此，代码全部编写完成。保存后，关闭该工作簿。再重新打开工作簿，如果没有选择与创建工具栏菜单名称相同的工作表，则会出现下面的工具栏：
如果选择的复选框项目与创建工具栏菜单的工作表名相同，则会出现下面的工具栏：
2009年10月22日, 1:26 下午
Loading ...
下面，创建一个简单的用户窗体，用于输入“入职员工信息”数据。
设计用户窗体
下表是个简单的“入职员工信息”数据库，用户窗体用于收集信息并将数据信息保存到该数据库中。
打开VBE，插入用户窗体，默认名为UserForm1。按下表在用户窗体中添加控件并设置属性。
完成的用户窗体如下图所示。
编写代码
1 编写找到数据库工作表中下一个空白行的代码
在VBE中，插入一个类模块，并命名为cExcelUtils，输入下列代码：
Function FindEmptyRow(ws As Worksheet) As Long
Dim lngReturn As Long
lngReturn = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
FindEmptyRow = lngReturn
End Function2 编写代码以包含每个员工信息的值，以及存储数据库工作表的位置，将数据保存到数据库
插入一个类模块，并命名为cEmployeeInfo，添加下面的代码在模块的声明部分：
Private m_lngID As Long
Private m_strName As String
Private m_strSchool As String
Private m_blnAbility As Boolean
Private m_blnObey As Boolean
Private m_xlWksht As Worksheet
Private m_oXL As cExcelUtils
前5个变量是我们在用户窗体中要输入的数据，以及从数据库工作表中产生的ID字段。变量m_xlWksht包含数据库工作表的位置。变量m_oXL决定在哪里放置新数据。
首先，添加数据属性。
Property Get ID() As Long
ID = m_lngID
End Property
Property Get Name() As String
Name = m_strName
End Property
Property Let Name(newName As String)
m_strName = newName
End Property
Property Get School() As String
School = m_strSchool
End Property
Property Let School(newSchool As String)
m_strSchool = newSchool
End Property
Property Get Ability() As Boolean
Ability = m_blnAbility
End Property
Property Let Ability(newAbility As Boolean)
m_blnAbility = newAbility
End Property
Property Get Obey() As Boolean
Obey = m_blnObey
End Property
Property Let Obey(newObey As Boolean)
m_blnObey = newObey
End Property
Property Get DBWorkSheet() As Worksheet
Set DBWorkSheet = m_xlWksht
End Property
Property Set DBWorkSheet(newSheet As Worksheet)
Set m_xlWksht = newSheet
End Property注意，ID属性没有Property Let方法，因此该属性是只读的。
下面，添加GetNextID方法找到最后一行，从第一列中获取值，然后增加1，以此来设置ID属性的值。
Public Function GetNextID() As Long
Dim lngReturn As Long
lngReturn = m_xlWksht.Cells(Rows.Count, 1).End(xlUp).Value + 1
m_lngID = lngReturn '设置ID属性
GetNextID = lngReturn
End Function接下来，添加初始化和清除代码：
Private Sub Class_Initialize()
Set m_oXL = New cExcelUtils
End Sub
Private Sub Class_Terminate()
Set m_oXL = Nothing
End Sub再继续完善该类的功能。先添加一些验证代码。如果Name属性和School属性没有数据的话，则不会保存记录。
Public Function ValidateData() As Boolean
Dim blnReturn As Boolean
If (Len(Me.Name & "") * Len(Me.School & "")) = 0 Then
blnReturn = False
Else
blnReturn = True
End If
ValidateData = blnReturn
End Function通过文本值的长度相乘，能够决定是否填充数据。
接下来，编写保存功能的代码。需要知道下一个可用行的行号为数据输入，需要知道该行所在的工作表，并且如果没有错误，返回True。
Public Function Save() As Boolean
Dim lngNewRowNum As Long
Dim blnReturn As Boolean
If m_xlWksht Is Nothing Then
blnReturn = False
GoTo Exit_Function
End If
lngNewRowNum = m_oXL.FindEmptyRow(m_xlWksht)
With m_xlWksht
.Cells(lngNewRowNum, 1).Value = Me.ID
.Cells(lngNewRowNum, 2).Value = Me.Name
.Cells(lngNewRowNum, 3).Value = Me.School
.Cells(lngNewRowNum, 4).Value = Me.Ability
.Cells(lngNewRowNum, 5).Value = Me.Obey
End With
If Err.Number = 0 Then
blnReturn = True
End If
Exit_Function:
Save = blnReturn
Exit Function
End Function代码首先检查以确保工作表对象存在，如果不存在则返回False并退出函数。接下来，从cExcelUtils对象中获取空行位置。然后，使用代表数据库工作表的m_xlWksht变量，使用从类属性中的数据填充每列。最后，检查没有发生错误，设置返回值为True，然后退出函数。
这就是cEmployeeInfo类，包含从用户窗体中的输入值，为任何新记录找到下一个ID值，保存数据到工作表中下一个空行。
编写用户窗体代码
在用户窗体代码模块中添加下列模块级变量：
Private m_oEmployeeInfo As cEmployeeInfo
Private m_blnSaved As Boolean
变量m_blnSaved存储从m_oEmployeeInfo对象的Save方法中返回的值。下面，编写用户窗体初始化和中止事件代码：
Private Sub UserForm_Initialize()
Set m_oEmployeeInfo = New cEmployeeInfo
Set m_oEmployeeInfo.DBWorkSheet = Sheets("入职员工信息")
m_oEmployeeInfo.GetNextID
lblID.Caption = m_oEmployeeInfo.ID
m_blnSaved = False
ClearForm
End Sub
Private Sub UserForm_Terminate()
Set m_oEmployeeInfo = Nothing
End Sub在用户窗体初始化时，实例化oEmployeeInfo对象，然后设置DBWorksheet属性。然后，获取下一个可用的ID号并将其放置到标签中。也清除了窗体中的控件值。
Private Sub ClearForm()
Me.txtName.Value = ""
Me.txtSchool.Value = ""
Me.chkAbility.Value = False
Me.chkObey.Value = False
End Sub用户窗体中有三个命令按钮：一个用于保存输入的数据，一个用于清除用户窗体数据并添加新记录，一个用于取消数据输入操作并且不保存数据而关闭用户窗体。
“保存”按钮应该执行下列功能：
- 发送数据到cEmployeeInfo类
- 验收数据，如果数据无效则返回一条消息
- 如果数据有效则保存数据，并且如果保存成功则返回一条消息
- 保存后清除用户窗体数据，并重设保存标志
代码如下：
Private Sub cmdSave_Click()
With m_oEmployeeInfo
.Name = txtName.Text
.School = txtSchool.Text
.Ability = chkAbility.Value
.Obey = chkObey.Value
End With
If Not m_oEmployeeInfo.ValidateData Then
MsgBox "姓名和毕业院校必填", vbOKOnly, "不能保存"
Exit Sub
Else
m_blnSaved = m_oEmployeeInfo.Save
End If
DoAfterSave m_blnSaved
End Sub过程DoAfterSave用于执行清理。
Private Sub DoAfterSave(success As Boolean)
If success Then
ClearForm
lblID.Caption = m_oEmployeeInfo.GetNextID
MsgBox "记录已保存"
Else
MsgBox "没有保存记录"
End If
m_blnSaved = False '重设标志
End Sub“新建”按钮的代码如下，在新建之前，检查文本字段看用户窗体中是否有任何数据：
Private Sub cmdNew_Click()
'为新记录设置窗体
Dim iAnswer As Integer
'检查当前记录是否被保存
If Not m_blnSaved Then '是否有输入的文本没有被保存
If (Len(Me.txtName.Value & "") + Len(Me.txtSchool.Value & "")) <> 0 Then
iAnswer = MsgBox("有没有保存的数据,想继续吗?", vbYesNo, "没有保存数据")
If iAnswer = vbYes Then
ClearForm
End If
Else
ClearForm
End If
End If
End Sub“取消”按钮用来清除用户窗体并关闭该用户窗体：
Private Sub cmdCancel_Click()
ClearForm
Unload UserForm1
End Sub现在，运行用户窗体来看看效果。
如上图所示，当“入职员工信息”用户窗体显示后，ID显示为102，而表中最后一行的ID值为101，第3行为可用的数据输入行。
现在，可以测试代码，在“姓名”文本框中输入信息，而让“毕业院校”留空，单击“保存”按钮，此时会弹出消息提示框，如下图所示。
输入“毕业院校”信息，选择必要的复选框，单击“保存”。此时，显示保存成功的消息框，第3行已经包含了刚才在用户窗体中输入的数据。注意到，用户窗体中的ID号现在已更新，以便输入下一条记录。
再测试“新建”按钮。单击“新建”按钮，用户窗体中除ID号外都为空，什么也没有发生。然而，如果你选择了复选框，再单击该按钮，会清除复选框的选择。如果输入了姓名，而单击“新建”按钮，将会收到一条警告数据没有保存的消息，如下图所示。
如果单击“否”，将返回到用户窗体而不会有任何变化；如果单击“是”，将清除用户窗体中的数据，以便输入新数据。
至此，一个简单的数据输入窗体已经完成。这里使用了类模块技术。
2009年10月17日, 12:49 下午
Loading ...
类模块能够让你创建拥有自已的方法和属性的新对象。类模块可用于封装复杂的代码，并且公开与创建的对象相关的属性和方法，只需要简单地调用这些属性和方法，而不需要知道其如何实现。
了解属性、方法和事件
先了解一下属性、方法和事件的概念。
创建对象时，该对象可以具有属性、方法和事件。例如，假设对象是一颗树，那么它将具有属性（例如高度、宽度，等）、方法（例如生长，等）、以及将会发生的事件（例如，死）。
属性：指某种特征，例如姓名、创建者、高度、宽度，属性可以是只读、只写或可读/写。在命名属性时，应该使用名词，例如MyComputer.Name，其中MyComputer是对象，Name是其属性。
方法：指该对象生存期间发生的行为。例如，tree（树）对象在整个生命期间都能生长。在命名方法时，选择动词或动词短语，例如MyComputer.GetIP。
事件：指对象发生了什么。当树死时（按类的说法，当对象“中止”时），事件发生。比方说，如果担心树死，那么可以钩挂该事件，将之放到日记里，到时候进行纪念性活动。
方法和事件都使用动词，例如有Open事件，也有Open方法，那么怎么知道哪个是事件，哪个是方法呢？方法是指令，指示应用程序打开文档、工作簿或数据库；事件是在处理过程中发生了什么。
下面的示例帮助区分方法和事件：
- MyComputer.GetIP：获取我的计算机的IP的方法。
- MyComputer_OnGetIP：当获取IP地址时触发的事件。
通常，你不会在事件名称前添加前缀On，但建议使用这种方式，使得容易理解和区分方法和事件。
使用属性
属性是对象的一个重要方面。例如，对于Excel工作簿，可以使用Path属性获取工作簿的路径，可以修改Worksheet对象的Name属性更改工作表的名称。
设置属性是创建类模块的第一步。
在VBA工程中，插入类模块，并命名为clsProperty。
Property Let
首先，声明包含属性值的全局变量。假设对象接受Name属性，则在类模块的声明部分，编写下面的代码：
接着，编写该属性的代码：
Property Let name(ByVal strName As String)
gstrName = strName
End Property现在，可以使用与修改其它对象的Name属性相同的方法修改该属性。在标准模块中，输入下列代码：
Sub clsProperty()
Dim MyComputer As New clsProperty
MyComputer.name = "My Computer Name"
Set MyComputer = Nothing
End Sub注意到，在类模块中，仅使用关键字Let定义了一个属性，因此是一个只写类。也就是说，可以通过写入新值来修改值，但不能读取该属性的值。
Property Get
上面的内容介绍了如何对属性写入值，接下来介绍如何获取属性值。此时，需要使用关键字Get。在前面的类模块中添加代码：
Property Get Name() As String
Name = gstrName
End Property在标准模块中编写下面的代码测试：
Sub clsProperty()
Dim MyComputer As New clsProperty
MyComputer.Name = "My Computer Name"
MsgBox MyComputer.Name
Set MyComputer = Nothing
End Sub经过代码完善后，clsProperty类变成了一个可读写的类。
记住，Let允许对属性写入值，而Get允许获取属性值。在上例中，使用关键字Let提供计算机名称为“My Computer Name”，然后使用关键字Get获取计算机名称，返回“My Computer Name”。
在程序结束前，使用关键字Set将变量的值设置为Nothing，以释放占用的内存，防止内存泄漏。
使用方法
方法指诸如Add（添加）、Update（更新）、MoveNext（移至下一个）、Clear（清除）、Delete（删除）等操作，使用方法的人只需实例化类并调用方法，而不需要理解该方法是如何实现的。
下图展示在声明clsClients类的新实例对象Client后，能够添加新客户，统计客户数，定义名称，或者给客户发邮件，等。
在类模块中，方法只是编写的过程或函数。如果需要返回值，那么需要使用函数，否则，使用过程执行某项操作。
下面让我们创建上图所示的方法。这里，使用Collection对象来存储客户的信息。
首先，声明一个代表客户集合的全局变量：
Dim gcolClients As New Collection
接着，开始编写方法代码。本例中，创建Add、Count、Delete和GetDetails方法。代码如下：
Sub Add(ByVal strName As String)
Dim lngIDClient As Long
On Error Resume Next
lngIDClient = gcolClients.Count + 1
gcolClients.Add strName, CStr(lngIDClient)
End Sub
Function Count() As Long
Count = gcolClients.Count
End Function
Sub Delete(ByVal strIDClient As String)
On Error Resume Next
If gcolClients.Count = 0 Then Exit Sub
gcolClients.Remove (strIDClient)
repopulate
End Sub
Function GetDetails(ByVal strIDClient As String) As Variant
On Error Resume Next
If gcolClients.Count = 0 Then
GetDetails = vbNullString
Exit Function
End If
GetDetails = gcolClients.Item(strIDClient)
End Function
Private Sub repopulate()
Dim colTemp As New Collection
Dim lngCount As Long
On Error Resume Next
For lngCount = 1 To gcolClients.Count
colTemp.Add gcolClients.Item(lngCount), CStr(lngCount)
Next
Set gcolClients = Nothing
Set gcolClients = colTemp
End Sub为了测试该类，在标准模块中，编写下面的代码：
Sub clsClients()
Dim client As New clsClients
With client
.Add ("张三")
.Add ("李四")
.Add ("王五")
.Name = .GetDetails(2)
MsgBox .Name
.Delete (2)
.Name = .GetDetails(2)
MsgBox .Name
MsgBox .Count
End With
Set client = Nothing
End Sub上面的代码中，添加了3个客户。然后，获取第2个客户的详情，并通过消息框显示。接着，删除该客户，并再次请求索引值为2的客户信息，检查集合中存放的顺序和数量发生了什么变化，显示客户名并统计集合中剩下多少客户。
使用事件
事件指在执行操作时发生的事情。事件可以被指定给对象，或者有更广泛的含义，像应用程序级的事件。例如，上文中的类有两个最基本的事件，一个事件在初始化类时触发，另一个事件在中止类时触发。
Private Sub Class_Initialize()
'代码
End SubPrivate Sub Class_Terminate()
'代码
End Sub可以使用这两个事件控制自已的类，也可以添加事件来控制应用程序或其它对象。
2009年09月30日, 2:06 下午
Loading ...
下面介绍如何在Excel中创建自定义弹出菜单。
Excel有许多可用的右键弹出菜单，其内容取决正在做什么，术语称为上下文菜单。例如，在单元格中单击右键，将出现“单元格”弹出菜单及其可用的选择。这个菜单可以定制，即允许在其中添加项目或者禁用项目。
取决于需要，下拉菜单可能会变得非常巨大。进一步说，如果取决于单元格内容而为每个单元格获得相同的菜单，可能会有太多的选择。一个完整的基于单元格内容或区域的自定义菜单，将会更好地满足特定的需要。
下面的代码使得您在当前工作簿的任何工作表中，右键单击分别填充有红色、黄色和绿色阴影的单元格时，创建并弹出三个自定义菜单（红色、黄色和绿色）。
本示例需要在Workbook.Open事件中编写代码，同时需要一个代码模块和一个类模块。
关键是类模块。类模块包含工作表事件的处理，无论何时在工作簿的任何工作表中发生操作时触发该事件。特别需要说明的是Worksheet.BeforeRightClick事件，正如其名字所表示的意思，即当用户右击工作表时发生默认的操作之前希望做的事情。
本例中，Range.Interior属性用于访问单元格的Interior.ColorIndex属性。取决于颜色返回的值，取消了默认的弹出菜单，并且根据返回的属性值显示相应的弹出菜单。
这项技术可用于自定义Excel解决方案，限制最终用户只做特定的任务。
Workbook_Open
Workbook_Open事件处理建立三个弹出菜单，并在类中创建工作表对象。打开VBE，将下面的代码粘贴到ThisWorkbook模块中：
Private Sub Workbook_Open()
Set cb_Red = CreateSubMenu("红色")
Set cb_Yellow = CreateSubMenu("黄色")
Set cb_Green = CreateSubMenu("绿色")
Call SetupAllWSEvents
End Sub代码模块
代码模块包含类设置和实际的菜单创建过程。在VBE中，插入一个标准模块，将下面的代码粘贴到该模块中：
Global cb_Red As CommandBar
Global cb_Yellow As CommandBar
Global cb_Green As CommandBar
Global WSObj As Collection
Global ws As Worksheet
Sub SetupAllWSEvents()
Dim WSo As clsWs
Set WSObj = Nothing
Set WSObj = New Collection
For Each ws In ActiveWorkbook.Worksheets
Set WSo = New clsWs
Set WSo.WSToMonitor = ws
WSObj.Add WSo, ws.Name
Next ws
End Sub
Function CreateSubMenu(strCB) As CommandBar
Const CBPREFIX = "CustomPopUp"
Dim cb As CommandBar
Dim cbc As CommandBarControl
Dim strCBName As String
'自定义菜单名称
strCBName = CBPREFIX & strCB
'移除以前的实例
Call DeleteCommandBar(strCBName)
'添加弹出菜单到CommandBars集合
Set cb = CommandBars.Add(Name:=strCBName, _
Position:=msoBarPopup, _
MenuBar:=False, _
Temporary:=False)
'添加控件
Set cbc = cb.Controls.Add
With cbc
.Caption = strCB & " 控件 1"
.OnAction = "DummyMessage"
End With
Set cbc = cb.Controls.Add
With cbc
.Caption = strCB & " 控件 2"
.OnAction = "DummyMessage"
End With
Set CreateSubMenu = cb
Set cbc = Nothing
Set cb = Nothing
End Function
Sub DeleteCommandBar(cbName)
On Error Resume Next
CommandBars(cbName).Delete
End Sub
Sub DummyMessage()
MsgBox CommandBars.ActionControl.Caption, vbInformation + vbOKOnly, "Dummy Message"
End Sub类模块
类模块根据目标单元格的特征决定弹出哪个菜单。在VBE中，插入类模块，将其名字改为clsWS，并在其中粘贴下列代码：
Dim WithEvents aWS As Worksheet
Property Set WSToMonitor(uWS As Worksheet)
Set aWS = uWS
End Property
Private Sub aWS_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Select Case Target.Interior.ColorIndex
Case 3, 9
cb_Red.ShowPopup
Cancel = True '使标准的单元格弹出菜单失效
Case 4, 10, 14, 35, 43, 50, 51, 52
cb_Green.ShowPopup
Cancel = True
Case 6, 12, 36, 44
cb_Yellow.ShowPopup
Cancel = True
Case Else
Cancel = False
End Select
End Sub代码测试
如上图所示，在某工作表中分别使用红色、黄色、绿色填充单元格，保存并关闭工作簿。然后重新打开该工作簿，此时在有颜色的单元格中单击右键，会出现不同的自定义弹出菜单。
示例下载
注：来源于Excel Team Blog，本文稍有调整。
2009年04月27日, 12:56 下午
Loading ...
在《链接用户窗体与工作表》一文中曾经介绍了在用户窗体中显示工作表的数据的方法。这里，将介绍另一种情况，即在用户窗体中查找工作表中满足特定条件的所有记录，这是Dick的博客中所列举的一个示例，本文稍作修改。
如下图所示，在工作表Sheet1中，姓名为“张三”的共有三条记录，在姓名右侧的文本框中输入“张三”后，将自动显示第1条记录的相关内容，然后可以单击“前一条”和“后一条”按钮来回显示相关的记录。
首先，使用Find方法根据查找条件查找到满足条件的所有记录，并将其赋值给Range变量。接着，使用Property Set语句创建的自定义属性将Range变量存储的记录区域传递给用户窗体。为了确保引用的记录区域与工作表中出现的顺序相同，在Find方法中使用了After参数并将其值设置为搜索区域的最后一个单元格，这样Find方法将从单元格区域的第一个单元格开始搜索。
将用户窗体命名为UPos，其中的一些控件及其名称为：姓名文本框（txtName）、工作内容文本框（txtWork）、共有记录的文本框（txtY）、第几条记录的文本框（txtX）、前一条按钮（cmdPrev）、后一条按钮（cmdNext），还有一些标签控件。
在标准模块中输入下列代码：
Sub ShowPos()
Dim ufPos As UPos '用户窗体变量
Dim rFound As Range '存储当前找到的单元格
Dim rNameRange As Range '要搜索的单元格区域
Dim sFirstAdd As String '第一个被找到的单元格的地址
Dim rAllFound As Range '所有找到的单元格
'从用户处获取数据,这里为了介绍方便采用了硬编码
Const strName As String = "张三"
Set rNameRange = Sheet1.Range("A2:A8")
'查找
Set rFound = rNameRange.Find(strName, rNameRange(rNameRange.Cells.Count), xlValues, xlWhole)
'如果找到
If Not rFound Is Nothing Then
'存储第一个找到的单元格的地址
sFirstAdd = rFound.Address
'添加找到的单元格到所有找到的单元格区域中
Set rAllFound = rFound
'继续查找直到循环到开始处为止
Do
Set rFound = rNameRange.FindNext(rFound)
If rFound.Address <> sFirstAdd Then
Set rAllFound = Union(rAllFound, rFound)
End If
Loop Until rFound.Address = sFirstAdd
'创建用户窗体
Set ufPos = New UPos
'传递单元格区域到用户窗体
Set ufPos.AllFound = rAllFound
ufPos.Initialize
ufPos.Show
Else
MsgBox "没有找到匹配的数据!"
End If
Set ufPos = Nothing
End Sub在用户窗体模块中，声明一些模块级的变量来包含传递的区域以及当前显示的区域。
Private mrAllFound As Range
Private mrCurrent As Range
Property Set AllFound(RHS As Range)
Set mrAllFound = RHS
End Property在显示用户窗体之前，要初始化该窗体，使用查找到的第一条记录填充窗体中的相应控件。
Public Sub Initialize()
'设置当前记录为第一条记录
If Not mrAllFound Is Nothing Then
Set mrCurrent = mrAllFound(1)
Me.txtName.Text = mrCurrent.Value
Me.txtWork.Text = mrCurrent.Next.Value
Me.txtY.Text = mrAllFound.Cells.Count
Me.txtX.Text = 1
End If
End Sub前一条按钮和后一条按钮使用FindPrevious方法和FindNext方法将记录移动到合适的位置。
Private Sub cmdNext_Click()
'设置当前单元格
Set mrCurrent = mrAllFound.FindNext(mrCurrent)
Me.txtName.Text = mrCurrent.Value
Me.txtWork.Text = mrCurrent.Next.Value
'增加计数器值
Me.txtX.Text = Me.txtX.Text + 1
End Sub
Private Sub cmdPrev_Click()
Set mrCurrent = mrAllFound.FindPrevious(mrCurrent)
Me.txtName.Text = mrCurrent.Value
Me.txtWork.Text = mrCurrent.Next.Value
Me.txtX.Text = Me.txtX.Text - 1
End Sub最后，当第几条文本框中的值变化时，启用或禁用按钮使得用户不能试图到达不存在的记录。
Private Sub txtX_Change()
'启用/禁用按钮
If Me.txtX.Text = 1 Then
Me.cmdPrev.Enabled = False
Else
Me.cmdPrev.Enabled = True
End If
If Me.txtX.Text = Me.txtY.Text Then
Me.cmdNext.Enabled = False
Else
Me.cmdNext.Enabled = True
End If
End Sub示例文档下载：
