ExcelVBA类代码实例集锦

1,类动态数组控件
‘2007VBA技巧
‘快盘\Mytb\更新\类\类动态数组控件.xlsm
‘2013-6-16
类模块代码：
erForm
PublicWithEventsmyTextAsMSForms.TextBox
PublicIndexAsInteger
PrivateSubmyText_Change()
Index=Mid(,8)
Iffrm.Controls("Textbox"&Index)<>""Then
="控件事件：Change"&vbCrLf&_
"控件名称："&frm.Controls("Textbox"&Index).Name&vbCrLf&_
"Text属性："&frm.Controls("Textbox"&Index).Text
EndIf
EndSub
PrivateSubmyText_DblClick(ByValCancelAsMSForms.ReturnBoolean)
Index=Mid(,8)
Iffrm.Controls("Textbox"&Index)<>""Then
="控件事件：DblClick"&vbCrLf&_
"控件名称："&frm.Controls("Textbox"&Index).Name&vbCrLf&_
"Cancel属性："&Cancel
EndIf
EndSub
KeyUp事件与Change事件重迭，二者取其一
PrivateSubmyText_KeyUp(ByValKeyCodeAsMSForms.ReturnInteger,ByValShiftAsInteger)
Index=Mid(,8)
Iffrm.Controls("Textbox"&Index)<>""Then
="控件事件：KeyUp"&vbCrLf&_
"控件名称："&frm.Controls("Textbox"&Index).Name&vbCrLf&_
"按键值：&H"&Hex$(KeyCode)
EndIf
EndSub
PrivateSubmyText_MouseMove(ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByVal YAsSingle)
SelectCaseIndex
Case3
="3"
Case8
="8"
Case4
="4"
Case9
="9"
CaseElse
=""
EndSelect
EndSub
模块1代码：
Publica(1To14)AsmyText
Subformshow()
Userform2.Show
EndSub
窗体代码：
PrivateSubCommandButton1_Click()
Dimi&,t$
Fori=1To14
Ifa(i).myText.Text<>""Then
t=t&"控件名称："&a(i)&vbTab&"Text属性："&a(i).myText.Text&vbCrLf
EndIf
Nexti
MsgBoxt
EndSub
PrivateSubUserForm_Initialize()
Dimi&
Fori=1To14
Seta(i)=NewmyText
Seta(i).myText=Me.Controls("Textbox"&i)
Seta(i).frm=Me
Nexti
EndSub
工作表代码：
PrivateSubCommandButton1_Click()
Userform2.Show
EndSub
2,复选框选择
‘快盘\Mytb\更新\类\类0928..xls
‘当复选框选择到7个时，其它的复选框不能再选择。

当复选框选择小于7个，其它的复选框还能继续选择。

类模块代码：
PublicWithEventscheAsMSForms.CheckBox
erForm
PrivateSubche_Change()'类的数据改变事件
DimindexAsLong
index=Mid(,9)'取出checkboxN中的数字N
Iffrm.Controls("checkbox"&index)=TrueThen
a=a&Format(index,"00")&","
n=n+1
Ifn=7Then
Fori=1To18
b=Format(i,"00")
IfInStr(a,b)=0Then
frm.Controls("checkbox"&i).Enabled=False
EndIf
Next
Else
EndIf
Else
n=n-1
a=Replace(a,Format(index,"00"),"")
Fori=1To18
frm.Controls("checkbox"&i).Enabled=True
Next
EndIf
EndSub
模块1代码：
Publicnewclass(1To18)Asche类,n&,a$
Subformshow()
UserForm1.Show
EndSub
窗体代码：
PrivateSubUserForm_Initialize()
Fori=1To18
Setnewclass(i)=Newche类'创建一个新的che类对象
Setnewclass(i).che=Controls("checkbox"&i)'设置新类和checkbox(i)控件创建关键Setnewclass(i).frm=Me'类窗体也和当前窗体建立关联
Next
EndSub
3,限制多个TEXTBOX的输入，使其只能输入数值
‘快盘\Mytb\更新\类\如何限制多个TEXTBOX的输入_zhaogang1980.xls
‘6447-1-1.html
类模块代码：
PublicWithEventsTxtboxAsMSForms.TextBox
PrivateSubTxtbox_Change()
WithCreateObject("vbscript.regexp")
.Global=True
.Pattern="[^0-9.]+"
If.test(Txtbox.Text)Then
Txtbox.Text=.Replace(Txtbox.Text,"")
EndIf
EndWith
EndSub
模块1代码：
SubMacro1()
UserForm1.Show
EndSub
窗体代码：
DimTxt()AsNewclsTxt
PrivateSubUserForm_Initialize()
DimctlAsControl,m&
ForEachctlInMe.Controls
IfTypeName(ctl)="TextBox"Then
<>"TextBox1"Then
m=m+1
ReDimPreserveTxt(1Tom)
SetTxt(m).Txtbox=ctl
EndIf
EndIf
Next
EndSub
PrivateSubTextBox1_Exit(ByValCancelAsMSForms.ReturnBoolean)'第一个不需要类模块IfTextBox1.Text=""ThenExitSub
IfIsDate(TextBox1.Text)=FalseThen
Cancel=True
TextBox1.Text=""
EndIf
EndSub
4，限制输入字母
‘8095-1-1-14725.html
PrivateWithEventstAsMSForms.TextBox
PrivateSubt_KeyPress(ByValKeyAsciiAsMSForms.ReturnInteger)
'限制只可以输入数字，不可输入字母和其他符号
SelectCaseKeyAscii
Case48To57
Case46
IfInStr(1,t.Text,".")Then
KeyAscii=0
EndIf
CaseElse
KeyAscii=0
EndSub
PrivateSubt_KeyUp(ByValKeyCodeAsMSForms.ReturnInteger,ByValShiftAsInteger) '限制中文输入
WithCreateObject("vbscript.regexp")
.Global=True
.Pattern="[^0-9.]+"
If.test(t.Text)Then
t.Text=.Replace(t.Text,"")
EndIf
EndWith
EndSub
PublicSubtk(iAsOLEObject)
'获取oleboject对象
Sett=i.Object
EndSub
DimAr(1To100)AsTT
'定义数组类
Subjustest()
DimjAsOLEObject,KAsByte
ForEachjInSheet1.OLEObjects
IfTypeName(j.Object)="TextBox"Then
'如果为TEXTBOX控件
=""
'清空文本框
K=K+1:SetAr(K)=NewTT
'同时创建类实体
Ar(K).tkj
'给类实体赋值，激活事件。

EndIf
Next
EndSub
5，表格上的按钮
‘telnet_zhaogang1960。

xls
‘类模块clsCmd中代码：
mandButton
PrivateSubCmdbox_Click()
MsgBoxCmdbox.Caption
EndSub
‘表格1上的ActiveX按钮控件
DimCmd(1To3)AsNewclsCmd
PrivateSubWorksheet_Activate()
DimiAsByte
SetCmd(i).Cmdbox=Me.OLEObjects("CommandButton"&i).Object
Next
EndSub
PrivateSubWorksheet_Deactivate()
EraseCmd
EndSub
6,求助由代码生成的控件的事件by:山菊花
‘当光标移入某个文本框，这个文本框的背景色变为蓝色，前景改为白色
‘7834-1-1.html
类模块代码：
mandButton
PublicWithEventsmBoxAsMSForms.TextBox
PrivateSubcmd_Click()
DimctlAsMSForms.Control
WithUserForm1
ForEachctlIn.Controls
IfTypeName(ctl)="TextBox"Then
<>"TextBox1"
ElseIfTypeName(ctl)="CommandButton"Then
<>"CommandButton1"<>"CommandButton2" EndIf
Next
.CommandButton1.Enabled=True
.CommandButton2.Enabled=False
EndWith
EndSub
PrivateSubmBox_MouseDown(ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValY AsSingle)
Fori=2To4
WithUserForm1.Controls("TextBox"&i)
.ForeColor=0
.BackColor=
EndWith
Next
mBox.BackColor=
mBox.ForeColor=
EndSub
窗体代码：
Privated(1To4)AsNewcmd_Class
PrivateSubCommandButton1_Click()
Fori=1To3
Setd(i).mBox=,True)
Withd(i).mBox
.Left=10
.Top=(i-1)*30+3
.Width=70
.Height=20
.Text=.Name
EndWith
Nexti
Setd(4).cmd=,True)
Withd(4).cmd
.Left=CommandButton2.Left
.Top=CommandButton2.Top+CommandButton2.Height
.Width=CommandButton2.Width
.Height=CommandButton2.Height
.Caption="删除"
EndWith
CommandButton1.Enabled=False
CommandButton2.Enabled=True
EndSub
PrivateSubCommandButton2_Click()
Fori=2To4
WithControls("TextBox"&i)
TextBox1.Value=Val(TextBox1.Value)+Val(.Value)
.ForeColor=0
.BackColor=
EndWith
Next
EndSub
7，窗体键盘
‘快盘\Mytb\更新\类\可否实现窗体键盘.xls
模块1代码：
PublicsNameAsString
类模块CmdArray代码：
mandButton
PrivateSubcmd_Click()
UserForm1.Controls(sName).Text=UserForm1.Controls(sName).Text&cmd.Caption
EndSub
类模块TxtArray代码：
PublicWithEventstxtAsMSForms.TextBox
PrivateSubtxt_MouseDown(ByValButtonAsInteger,ByValShiftAsInteger,ByValXAsSingle,ByValYAs Single)
sName=
EndSub
窗体代码：
PrivatearrCmd(0To10)AsCmdArray
PrivatearrTxt(1To4)AsTxtArray
PrivateSubUserForm_Initialize()
DimiAsInteger
DimcmdNewAsCmdArray
DimtxtNewAsTxtArray
Fori=0To10
SetcmdNew=NewCmdArray
SetcmdNew.cmd=Me.Controls("CommandButton"&i)
SetarrCmd(i)=cmdNew
SetcmdNew=Nothing
Next
Fori=1To4
SettxtNew=NewTxtArray
SettxtNew.txt=Me.Controls("TextBox"&i)
SetarrTxt(i)=txtNew
SettxtNew=Nothing
Next
EndSub
8，横道图
快盘\Mytb\更新\类\类入门\.xls
模块1代码：
Sub画线条()
DimstAsWorksheet,arrAsRange,tgAsRange
Setst=Sheets("横道图")
Setarr=st.Range("A5:A"&st.Range("A65536").End(xlUp).Row) ForEachtgInarr
DimLiAsNew类1
Li.SDate=DateValue(tg.Offset(0,3))
Li.Edate=DateValue(tg.Offset(0,4))
Li.st=st
Li.target=tg
Li.arr=st.Range(Cells(2,7),st.Cells(2,255).End(xlToLeft))
IfLi.lineThenDebug.Printtg
Next
EndSub
类模块类1代码：
'取左
Privatem_stAsWorksheet
PrivateM_SDateAsDate
PrivateM_EDateAsDate
PrivateM_targetAsRange
PrivateM_arrAsRange
ConstHeightAsInteger=3
PublicPropertyGetEdate()AsDate
Edate=M_EDate
EndProperty
PublicPropertyLetEdate(valueAsDate)
M_EDate=value
EndProperty
PublicPropertyGetSDate()AsDate
SDate=M_SDate
EndProperty
PublicPropertyLetSDate(valueAsDate)
M_SDate=value
EndProperty
PublicPropertyGetst()AsWorksheet
Setst=m_st
EndProperty
PublicPropertyLetst(stvalueAsWorksheet)
Setm_st=stvalue
EndProperty
PublicPropertyGettarget()AsRange
Settarget=M_target
EndProperty
PublicPropertyLettarget(tgvalueAsRange)
SetM_target=tgvalue
EndProperty
PublicPropertyGetarr()AsRange
Setarr=M_arr
EndProperty
PublicPropertyLetarr(valueAsRange)
SetM_arr=value
EndProperty
PublicFunctionGetDateLineLeft(ByValStartDateAsDate)AsSingle
DimtgAsRange,StartPointLeftAsSingle,iAsInteger
ForEachtgInarr
IfIsDate(tg.value)Then
IfYear(StartDate)=Year(tg.value)AndMonth(StartDate)=Month(tg.value)Then
'IfDateValue(Year(StartDate)&"-"&Month(StartDate)&"-"&"1")=DateValue(tg.Value)Then Debug.PrintDay(StartDate)
SelectCaseCInt(Day(StartDate))
CaseIs<CInt(tg.Offset(1,0))
Fori=1Totg.Offset(1,0).Column-1
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineLeft=StartPointLeft+(CInt(Day(StartDate))Mod10)*st.Columns(tg.Offset(1,0).Column).W idth/10
ExitFunction
CaseIs=CInt(tg.Offset(1,0))
Fori=1Totg.Offset(1,0).Column
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineLeft=StartPointLeft
ExitFunction
CaseIs<CInt(tg.Offset(1,0).Offset(0,1))
Fori=1Totg.Offset(1,0).Offset(0,1).Column-1
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineLeft=StartPointLeft+(CInt(Day(StartDate))Mod10)*st.Columns(tg.Offset(1,0).Offset(0,1). Column).Width/10
ExitFunction
CaseIs=CInt(tg.Offset(1,0).Offset(0,1))
Fori=1Totg.Offset(1,0).Column
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineLeft=StartPointLeft
ExitFunction
CaseIs<CInt(tg.Offset(1,0).Offset(0,1).Offset(0,1))
Fori=1Totg.Offset(1,0).Offset(0,1).Offset(0,1).Column-1
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineLeft=StartPointLeft+(CInt(Day(StartDate))Mod10)*st.Columns(tg.Offset(1,0).Offset(0,1). Offset(0,1).Column).Width/(CInt(tg.Offset(1,0).Offset(0,1).Offset(0,1))-20)
ExitFunction
CaseIs=CInt(tg.Offset(1,0).Offset(0,1).Offset(0,1))
Fori=1Totg.Offset(1,0).Column
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineLeft=StartPointLeft
ExitFunction
EndSelect
EndIf
EndIf
Nexttg
EndFunction
'取右顶点线条位置
PublicFunctionGetDateLineRight(ByValEndDateAsDate)AsSingle
DimarrAsRange,tgAsRange,StartPointLeftAsSingle,iAsInteger
Setarr=st.Range(Cells(2,7),st.Cells(2,255).End(xlToLeft))
ForEachtgInarr
IfIsDate(tg.value)Then
IfYear(EndDate)=Year(tg.value)AndMonth(EndDate)=Month(tg.value)Then
'IfDateValue(Year(EndDate)&"年"&Month(EndDate)&"月"&"1日")=tg.ValueThen
Debug.PrintDay(EndDate)
SelectCaseCInt(Day(EndDate))
CaseIs<CInt(tg.Offset(1,0))
Fori=1Totg.Offset(1,0).Column-1
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineRight=StartPointLeft+(CInt(Day(EndDate))Mod10)*st.Columns(tg.Offset(1,0).Column). Width/10
ExitFunction
CaseIs=CInt(tg.Offset(1,0))
Fori=1Totg.Offset(1,0).Column
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineRight=StartPointLeft
CaseIs<CInt(tg.Offset(1,0).Offset(0,1))
Fori=1Totg.Offset(1,0).Offset(0,1).Column-1
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineRight=StartPointLeft+(CInt(Day(EndDate))Mod10)*st.Columns(tg.Offset(1,0).Offset(0,1). Column).Width/10
ExitFunction
CaseIs=CInt(tg.Offset(1,0).Offset(0,1))
Fori=1Totg.Offset(1,0).Offset(0,1).Column
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineRight=StartPointLeft
ExitFunction
CaseIs<CInt(tg.Offset(1,0).Offset(0,1).Offset(0,1))
Fori=1Totg.Offset(1,0).Offset(0,1).Offset(0,1).Column-1
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineRight=StartPointLeft+(CInt(Day(EndDate))Mod10)*st.Columns(tg.Offset(1,0).Offset(0,1). Offset(0,1).Column).Width/(CInt(tg.Offset(1,0).Offset(0,1).Offset(0,1))-20)
ExitFunction
CaseIs=CInt(tg.Offset(1,0).Offset(0,1).Offset(0,1))
Fori=1Totg.Offset(1,0).Offset(0,1).Offset(0,1).Column
StartPointLeft=StartPointLeft+st.Columns(i).Width
Nexti
GetDateLineRight=StartPointLeft
ExitFunction
EndSelect
EndIf
EndIf
Nexttg
EndFunction
PublicFunctionGetLineTop(ByValtgAsRange)AsSingle
DimiAsInteger,LineTopAsSingle
Fori=1Totg.Row-1
LineTop=LineTop+st.Rows(i).Height
Nexti
GetLineTop=LineTop+tg.Height/3
EndFunction
PublicFunctionGetLineHeight()
GetLineHeight=Height
EndFunction
PublicFunctionline()AsBoolean
GetDateLineLeft(SDate),GetLineTop(target),GetDateLineRight(Edate)-GetDateLineLeft(SDate),GetLi neHeight).Select
=RGB(255,0,0)
=RGB(255,0,0)
EndFunction
工作表按钮代码：
PrivateSubCommandButton1_Click()
Application.Run"画线条"
EndSub
PrivateSubCommandButton2_Click()
ForEachobjInMe.Shapes
="CommandButton1"="CommandButton2"Then
Else
obj.Delete
EndIf
Next
EndSub
9，类模块入门_ExcelPerfect
这里简单地介绍VBA中的类模块，使大家能够在应用程序中创建并使用简单的类。

类是对象的“模板”。

对象可以是任何事物，而类不会做任何事情，也不会占用内存，只有当类成为对象并使用Set语句和New关键字实例化为具体对象后，才能做事情并占用内存。

实例化类为具体对象的语法为：
DimCAsClass1
SetC=NewClass1
上述语句创建了一个名为C的对象，该对象的数据类型为定义的类Class1。

在详细介绍类之前，让我们先看看VBA的用户自定义数据类型，即使用Type关键字定义的变量。

例如，下面的Type变量定义了雇员的信息：
TypeEmployee
NameAsString
AddressAsString
SalaryAsDouble
EndType
上面的语句定义了变量Employee，包含元素Name、Address和Salary。

接着，您可以声明一个Employee型的变量，并为其中的每个元素赋值：
Subtest()
DimFanAsEmployee
=“fanjy”
Fan.Address=“YiChang”
Fan.Salary=1000
EndSub
用户自定义类型是很有用的，但是有三个主要的局限：
1、在编译时必须声明所有的自定义类型变量。

虽然可以使用动态数组来处理多个自定义类型，但必须使用RedimPreserve关键词。

并且，不能在运行时添加新的自定义类型变量。

2、不能控制赋给自定义类型中元素的值。

例如，在上述代码中，有可能给Salary 元素赋一个负值。

3、自定义类型不做任何事情，只是静态地存储数据。

用户自定义类型被广泛用于在对WindowsAPI函数调用时，除此之外，使用类模块是更好的选择。

类克服了用户自定义类型的局限。

1、使用New关键字，可以创建任意数量的类的新实例，并且能够将其存储在Collection对象中。

2、使用PropertyLet/Set/Get语句，可以编写代码验证赋给类元素的值，并且可以编写当值改变时执行的相应代码。

例如，能够编写代码确保Salary的值不为负值。

3、类可以定义方法（使用Sub过程和Function过程），执行某项动作。

下面，让我们将自定义类型Employee转换为类。

首先，在VBE编辑器中插入一个类模块，并将其重命名为CEmployee，如图1所示。

（类模块由属性和方法组成，类本身类似于名词；属性可以当作形容词，用来描述类；方法则为动词，执行操作。

）
CEmployee类应该有三个属性：Name、Address和Salary。

在类模块的声明部分声明三个Private变量来存储这些值，属性的实际值被存储在这三个私有变量中。

PrivatepNameAsString
PrivatepAddressAsString
PrivatepSalaryAsDouble
因为这些变量都被声明为私有的，因此仅能在类内部访问，在类的外部是不可见的。

如何为这些变量赋值呢？这就是PropertyLet语句要做的工作。

每个私有变量都有相应的PropertyLet语句。

PropertyLetName(SAsString)
pName=S
EndProperty
PropertyLetAddress(SAsString)
pAddress=S
EndProperty
PropertyLetSalary(DAsDouble)
pSalary=D
EndProperty
PropertyLet语句用于给属性赋值，即将值引入类。

在上例中，简单地将引入的值赋给私有变量。

由于PropertyLet语句中能够包含代码，因此能够编写用于数据验证的代码。

例如，改写PropertyLetSalary函数中的代码，使之不允许接受负值：
PropertyLetSalary(DAsDouble)
IfD>0Then
pSalary=D
Else
‘错误提示
MsgBox“薪水怎能为负呢?”
EndIf
EndProperty
与PropertyLet函数相对应的是PropertyGet函数，用于从类中获取属性的值。

在CEmployee类中，相应的PropertyGet语句为：
PropertyGetName()AsString
Name=pName
EndProperty
PropertyGetAddress()AsString
Address=pAddress
EndProperty
PropertyGetSalary()AsDouble
Salary=pSalary
EndProperty
Let语句和Get语句的数据类型必须相匹配。

例如，LetSalary接受Double类型的值作为其参数，这意味着其返回的相应的Get属性的值必须是Double。

如果数据类型不一致，就会导致编译错误。

这些Get语句简单地将三个属性向外公开。

要创建只读属性，则忽略PropertyLet
语句而仅使用PropertyGet语句。

例如，WithholdingTax属性是只读的，在Get语句中的代码计算合适的值并将其公开，但避免从外部改变该属性的值：
PropertyGetWithholdingTax()AsDouble
WithholdingTax=some_tax_calculation
EndProperty
该属性没有对应的Let语句，因此该属性只读，没有办法将值赋给WithholdingTax。

类模块能够包含方法，例如CEmployee类有一个用于雇员复核薪水的方法：
PublicSubPrintPaycheck()
‘放置打印复核的实际代码
EndSub
好了，我们已经完成了CEmployee类的初步定义，如图1所示。

图1：CEmployee类
下面，在标准模块的代码中实例化类，并使用其属性和方法。

首先，在VBE编辑器中插入一个模块，声明一个CEmployee类型的变量。

（注意，在复杂的应用程序中，在类模块中声明并实例化另一个类是完全合法的）
DimEmpAsCEmployee
接下来，实例化该类，创建一个可用来工作的实际对象，如下列语句：
SetEmp=NewCEmployee
上述语句创建了一个名为Emp的对象，能够使用CEmployee类中的属性来引用特定的雇员信息，例如：
=“fanjy”
Emp.Address=“YiChang”
Emp.Salary=1000
这三个语句调用在CEmployee类中声明的PropertyLet语句来赋值给类中的私有变量。

我们能够使用下列代码读取对象的属性的值：
Debug.PrintEmp.Address
Debug.PrintEmp.Salary
上述语句调用类模块中的PropertyGet语句并获取数据。

我们也能读取类中的只读属性WithholdingTax：
Debug.PrintEmp.WithholdingTax
由于WithholdingTax属性没有相应的Let语句，因此不能给该属性赋值。

如果试图赋值：
Emp.WithholdingTax=4000
则会导致：“编译错误：不能给只读属性赋值”。

也能够调用方法来执行操作：
Emp.PrintPaycheck
在集合中存储类的多个实例
如果到运行时还不知道有多少个雇员，那么能够在运行时按需要创建多个Emp对象，每创建一个Emp对象之后将其存储在集合中。

例如：
DimCollAsNewCollection
DimNdxAsLong
DimEmpAsCEmployee
ForNdx=1ToNumberOfEmployees
SetEmp=NewCEmployee
‘设置Emp对象的属性
Coll.AddItem:=Emp,Key:=
NextNdx
上面的For…Next循环将创建CEmployee类的NumberOfEmployees个实例，具体数量由运行时决定，并将其存储在名为Coll的集合对象中。

之后，能够使用ForEach循环从Coll集合中获取每个雇员信息或执行操作：
ForEachEmpInColl
Emp.PrintPaycheck
NextEmp
类的Instancing属性
类的Instancing属性决定其可见性（或称作作用域），默认属性值为1-Private，意味着类仅能在包含该类的工程中创建和访问。

其他工程不能基于该类创建对象。

对于绝大多数应用程序来说，Private是足够了。

Instancing属性的另一个值是2-PublicNotCreatable，表明其他工程能够将变量声明为该类，但是不能使用Set语句创建该类的实例。

在多个工程间使用类
如果一个工作簿需要使用定义在另一个工作簿中的类，则需要在包含类模块的工作簿中编写代码导出类到另一个工程。

该类的Instancing属性必须是
2-PublicNotCreatable。

假设Book1.xls工作簿中包含一个名为Class1的类模块，Book2.xls需要使用该类。

首先，将Book1工作簿的工程名称从缺省的“VBAProject”修改为唯一的名称，例如MyProject。

然后，在VBE编辑器中激活Book2工作簿的界面，设置对Book1工作簿的引用，即在VBE中选择“工具——引用”，然后在列表中选择“MyProject”。

然后，在Book2中，创建如下声明：
PublicCAsMyProject.Class1
因为Instancing的属性值为PublicNotCreatable，所以可以声明一个Class1类的变量，但不能创建该类的实例。

因此，需要在Book1中编写一个函数来创建Class1的新实例，并返回该实例给Book2。

在Book1中，创建下面的过程：
PublicFunctionGetClass1()AsClass1
SetGetClass1=NewClass1
EndFunction
然后，在Book2中设置公共变量C为上述函数的结果，例如：
SetC=MyProject.GetClass1()
现在，C被设置为Class1的新实例。

好了，上面只是对类模块的一些初步介绍，还有一些知识未讲述，例如PropertySet 语句，留待以后在慢慢整理。

<完美Excel整理，仅供参考！>
10，设置类的默认属性
设置类的默认属性
在Excel中，许多对象都有一个默认的属性。

如果在使用某对象时，没有专门指定属性，则会使用该对象的默认属性。

例如，Range对象的Value属性是其默认属性，因此下列两行代码作用相同：
Range(“A1”).Value=123
Range(“A1”)=123
然而，VBA并没有提供一种简单的机制用于为类指定默认属性，但是确实可以指定默认的属性，只不过需要“费一些周折”。

假设有一个名为CMyClass的类，其代码如下：
OptionExplicit
Private pValue AsLong
Private pName AsString
PropertyGet Value()AsLong
Value=pValue
EndProperty
PropertyLet Value(V AsLong)
pValue=V
EndProperty
PropertyGet Name()AsString
Name=pName
EndProperty
PropertyLet Name(V AsString)
pName=V
EndProperty
如果没有指定默认属性，下面的测试将失败，导致运行时错误438——对象不支持该属性或方法。

Sub test()
Dim MyClass As CMyClass
Set MyClass=New CMyClass
MyClass=123
EndSub
要使Value属性为默认属性，可按下列步骤进行。

步骤1：保存工作簿。

步骤2：在VBE编辑器中打开CMyClass模块。

步骤3：单击“文件——移除CMyClass”。

步骤4：当出现“在移除CMyClass之前是否将其导出”的信息提示框时，选择“是”，保存该模块。

步骤5：在记事本或者其它文本编辑器中打开刚导出的文件CMyClass.cls。

步骤6：找到PropertyGetValue()过程，并在第一行添加下列语句：
AttributeValue.VB_UserMemId=0
此时，该过程的完整代码如下（其中，加粗部分为刚添加的语句）：
PropertyGetValue()AsLong
AttributeValue.VB_UserMemId=0
Value=pValue
EndProperty
步骤7：在记事本中保存该文件然后关闭。

步骤8：在VBE中，选择“文件——导入文件”，将刚才修改的文件导入。

注意，在VBE编辑器中看不到“Attribute”语句，它会读取并处理Attribute语句但是不会显示它们，也不会允许在编辑器中输入。

现在，在标准模块中运行下列代码：
Sub test()
Dim MyClass As CMyClass
Set MyClass=New CMyClass
MyClass=123
Debug.PrintMyClass
EndSub
运行正常。

因为在PropertyGet过程中添加了Attribute语句后，编译器就会将其当作默认属性。

（上述内容适合于Excel2000及以后的版本）
11，Excel工作表内的图表事件
‘快盘\Mytb\更新\类\类入门\Excel工作表内的图表事件.xls
模块1代码：
DimmchrAsNewchartclass
Subtest()
Setmchr.mychar=ActiveSheet.ChartObjects(1).Chart
EndSub
类模块chartclass代码：
PublicWithEventsmycharAsExcel.Chart
PrivateSubmychar_BeforeRightClick(CancelAsBoolean)
Cancel=True
EndSub
12，创建单元格类
‘快盘\Mytb\更新\类\类入门\创建单元格类.xls
模块1代码：
Subtest()
DimmrAsNewredrange
Setmr.myrng=Range("A1:a10")
EndSub
类模块redrange代码：
PropertySetmyrng(rngAsRange)
=3
=14
EndProperty
13，类的方法和属性
‘快盘\Mytb\更新\类\类入门\类的方法和属性1105.xls
模块1代码：
DimyuanAsNew圆的面积和周长计算模板
Subtest()
yuan.半径=Sheet1.[b1].Value
yuan.计算类型=Sheet1.[b2].Value
yuan.计算
EndSub
类模块”圆的面积和周长计算模板”代码：
Enum类型
周长
EndEnum
DimRAsDouble
PublicleixingAs类型
PropertyLet半径(bjAsDouble)
R=bj
EndProperty
PropertyLet计算类型(lxAs类型)
leixing=lx
EndProperty
Sub计算()
Ifleixing=面积Then
MsgBox"面积="&Application.Pi()*R^2
Else
MsgBox"周长="&2*Application.Pi()*R
EndIf
EndSub
14，按钮名称and事件
‘快盘\Mytb\更新\类\类入门\类模块课件-按钮名称and事件.xls 类模块”comclass”代码：mandButton PrivateSubmcom_Click()
MsgBoxmcom.Caption
EndSub
PropertySetmc(mandButton)
mcom.Caption=Mid(mcom.Caption,14,3)
EndProperty
窗体代码：
Dimc(4)AsNewcomclass
PrivateSubUserForm_Initialize()
Forx=1To4
Setc(x).mc=Me.Controls("CommandButton"&x)
Setc(x).mcom=Me.Controls("CommandButton"&x)
Nextx
EndSub
15，图片点击
‘快盘\Mytb\更新\类\类入门\图片点击.xls
类模块”ima”代码：PublicWithEventsMyimageAsImage
PrivateSubMyimage_Click()
MsgBox"你点击的是:"&
Thisworkbook的代码：
Dimnewclass(1To18)AsNewima
PrivateSubWorkbook_Open()
Fori=1To18
Setnewclass(i).Myimage=Sheet1.OLEObjects("image"&i).Object
Nexti
EndSub
16，封装api函数
‘快盘\Mytb\更新\类\类入门\封装api函数.xls
模块1代码：
PublicmforAsNewnoclass
Subf()
Setmfor.无标题窗体=UserForms(0)
Setmfor.单击事件=UserForms(0)
EndSub
类模块noclass代码：
PrivateDeclareFunctionDrawMenuBarLib"user32"(ByValhwndAsLong)AsLong PrivateDeclareFunctionGetWindowLongLib"user32"Alias"GetWindowLongA"(ByValhwndAsLong,ByValn IndexAsLong)AsLong
PrivateDeclareFunctionSetWindowLongLib"user32"Alias"SetWindowLongA"(ByValhwndAsLong,ByValnI ndexAsLong,ByValdwNewLongAsLong)AsLong PrivateDeclareFunctionFindWindowLib"user32"Alias"FindWindowA"(ByVallpClassNameAsString,ByVall pWindowNameAsString)AsLong
PrivateConstGWL_STYLEAsLong=(-16)
PrivateConstWS_CAPTIONAsLong=&HC00000
PublicWithEvents单击事件erForm
PropertySet无标题窗体(erForm)
hwnd=FindWindow("ThunderDFrame",myform.Caption)
SetWindowLonghwnd,GWL_STYLE,IStyle
DrawMenuBarhwnd
EndProperty
PrivateSub单击事件_Click()
Unload单击事件
EndSub
窗体代码：
PrivateSubUserForm_Initialize()
Callf
EndSub
17，分析活动单元格
‘“专业开发Excel”第7章
‘Analysis1.xls
类模块CCell代码PublicEnumanlCellType anlCellTypeEmpty
anlCellTypeLabel
anlCellTypeConstant anlCellTypeFormula
EndEnum PrivatemuCellTypeAsanlCellType PrivatemrngCellAsExcel.Range PropertySetCell(ByRefrngCellAsExcel.Range) SetmrngCell=rngCell
EndProperty
PropertyGetCell()AsExcel.Range
SetCell=mrngCell
EndProperty
PropertyGetCellType()AsanlCellType CellType=muCellType
EndProperty PropertyGetDescriptiveCellType()AsString SelectCasemuCellType CaseanlCellTypeEmpty DescriptiveCellType="Empty" CaseanlCellTypeFormula DescriptiveCellType="Formula" CaseanlCellTypeConstant DescriptiveCellType="Constant" CaseanlCellTypeLabel DescriptiveCellType="Label"
EndSelect
EndProperty
PublicSubAnalyze()
IfIsEmpty(mrngCell)Then
muCellType=anlCellTypeEmpty ElseIfmrngCell.HasFormulaThen muCellType=anlCellTypeFormula ElseIfIsNumeric(mrngCell.Formula)Then muCellType=anlCellTypeConstant
Else
muCellType=anlCellTypeLabel
EndIf
EndSub
模块1代码：PublicSubAnalyzeActiveCell() DimclsCellAsCCell
SetclsCell=NewCCell
SetclsCell.Cell=Application.ActiveCell
clsCell.Analyze
MsgBoxclsCell.DescriptiveCellType
EndSub
18，把选择的单元格加入集合
‘“专业开发Excel”第7章
‘Analysis2.xls
类模块CCell代码同上
模块代码：
PublicgcolCellsAsCollection'HoldsCellscollection PublicSubCreateCellsCollection() DimclsCellAsCCell
DimrngCellAsRange
'CreatenewCellscollection
SetgcolCells=NewCollection
'CreateCellobjectsforeachcellinSelection ForEachrngCellInApplication.Selection
SetclsCell=NewCCell
SetclsCell.Cell=rngCell
clsCell.Analyze
'AddtheCelltothecollection
gcolCells.AddItem:=clsCell,Key:=rngCell.Address NextrngCell
'DisplaythenumberofCellobjectsstored MsgBox"Numberofcellsstored:"&CStr(gcolCells.Count) EndSub
19，着色显示同类单元格
‘“专业开发Excel”第7章
‘Analysis3.xls
类模块CCell代码
PublicEnumanlCellType
anlCellTypeEmpty
anlCellTypeLabel
anlCellTypeConstant
anlCellTypeFormula
EndEnum
PrivatemuCellTypeAsanlCellType PrivatemrngCellAsExcel.Range
PropertySetCell(ByRefrngCellAsExcel.Range) SetmrngCell=rngCell
EndProperty
PropertyGetCell()AsExcel.Range
SetCell=mrngCell
EndProperty
PropertyGetCellType()AsanlCellType CellType=muCellType
EndProperty PropertyGetDescriptiveCellType()AsString SelectCasemuCellType CaseanlCellTypeEmpty DescriptiveCellType="Empty" CaseanlCellTypeFormula DescriptiveCellType="Formula" CaseanlCellTypeConstant DescriptiveCellType="Constant" CaseanlCellTypeLabel DescriptiveCellType="Label"
EndSelect
EndProperty
PublicSubAnalyze()
IfIsEmpty(mrngCell)Then
muCellType=anlCellTypeEmpty ElseIfmrngCell.HasFormulaThen muCellType=anlCellTypeFormula ElseIfIsNumeric(mrngCell.Formula)Then muCellType=anlCellTypeConstant
Else
muCellType=anlCellTypeLabel
EndIf
EndSub
PublicSubHighlight()
=Choose(muCellType+1,5,6,7,8)
EndSub
PublicSubUnHighlight()
=xlNone
EndSub
类模块CCells代码PrivatemcolCellsAsCollection PropertyGetCount()AsLong
Count=mcolCells.Count
EndProperty
PropertyGetItem(ByValvIDAsVariant)AsCCell SetItem=mcolCells(vID)
EndProperty
PrivateSubClass_Initialize()
SetmcolCells=NewCollection
EndSub
PublicSubAdd(ByRefrngCellAsRange) DimclsCellAsCCell
SetclsCell=NewCCell
SetclsCell.Cell=rngCell
clsCell.Analyze
mcolCells.AddItem:=clsCell,Key:=rngCell.Address EndSub
PublicFunctionNewEnum()AsIUnknown
SetNewEnum=mcolCells.[_NewEnum]
EndFunction
PublicSubHighlight(ByValuCellTypeAsanlCellType) DimclsCellAsCCell
ForEachclsCellInmcolCells
IfclsCell.CellType=uCellTypeThen
clsCell.Highlight
EndIf
NextclsCell
EndSub
PublicSubUnHighlight(ByValuCellTypeAsanlCellType) DimclsCellAsCCell
ForEachclsCellInmcolCells
IfclsCell.CellType=uCellTypeThen
clsCell.UnHighlight
EndIf
NextclsCell
EndSub
模块代码：
PublicgcolCellsAsCollection'HoldsCellscollection PublicSubCreateCellsCollection()
DimclsCellAsCCell
DimlIndexAsLong
DimlCountAsLong
DimrngCellAsRange
SetgclsCells=NewCCells
ForEachrngCellIn
gclsCells.AddrngCell
NextrngCell
'Countthenumberofformulacellsinthecollection.
ForlIndex=1TogclsCells.Count
IfgclsCells.Item(lIndex).CellType=anlCellTypeFormulaThen lCount=lCount+1
EndIf
NextlIndex
MsgBox"NumberofFormulas="&CStr(lCount) EndSub
PublicSubShowFormulas()
gclsCells.HighlightanlCellTypeFormula MsgBox"Formulashighlighted."
gclsCells.UnHighlightanlCellTypeFormula
EndSub
PublicSubShowConstants()
gclsCells.HighlightanlCellTypeConstant MsgBox"Constantshighlighted."
gclsCells.UnHighlightanlCellTypeConstant
EndSub
PublicSubShowEmpties()
gclsCells.HighlightanlCellTypeEmpty MsgBox"Emptycellshighlighted."
gclsCells.UnHighlightanlCellTypeEmpty
EndSub
PublicSubShowLabels()
gclsCells.HighlightanlCellTypeLabel MsgBox"Labelshighlighted."
gclsCells.UnHighlightanlCellTypeLabel
EndSub
20，单元格双击事件着色显示同类单元格
‘“专业开发Excel”第7章
‘Analysis4.xls
类模块CCell代码同上19
类模块CCells代码PrivatemcolCellsAsCollection PrivateWithEventsmwksWorkSheetAsExcel.Worksheet PropertyGetCount()AsLong
Count=mcolCells.Count
EndProperty
PropertyGetItem(ByValvIDAsVariant)AsCCell SetItem=mcolCells(vID)
EndProperty
PropertySetWorksheet(ByRefwksAsExcel.Worksheet) SetmwksWorkSheet=wks
EndProperty
PrivateSubClass_Initialize()
SetmcolCells=NewCollection
EndSub
PublicSubAdd(ByRefrngCellAsRange)。