ExcelVBA类代码实例集锦.docx

1, 类动态数组控件 2007VBA 技巧快盘Mytb更新类类动态数组控件.xlsm2013-6-16类模块代码：Public WithEvents frm As MSForms.UserFormPublic WithEvents myText As MSForms.TextBoxPublic Index As IntegerPrivate Sub myText_Change()Index = Mid(myText.Name, 8)If frm.Controls("Textbox" & Index) <> "" Thenfrm.Labell.Caption = 控件事件：Change" & vbCrLf & _控件名称："& frm.Controls("Textbox" & Index).Name & vbCrLf &"Text 属性："& frm.Controls("Textbox" & Index).TextEnd SubPrivate Sub myText_DblClick(ByVal Cancel As MSForms.ReturnBoolean)Index = Mid(myText.Name, 8)If frm.Controls("Textbox" & Index) <> "" Thenfrm.Labell.Caption = 控件事件：DblClick" & vbCrLf & _控件名称："& frm.Controls("Textbox" & Index).Name & vbCrLf & _"Cancel 属性："& CancelEnd IfEnd SubKeyUp事件与Change事件重迭，二者取其一Private Sub myText_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)Index = Mid(myText.Name, 8)If frm.Controls("Textbox" & Index) <> "" Then控件名称："& frm.Controls("Textbox" & Index).Name & vbCrLf & _按键值：&H" & Hex$(KeyCode)End IfEnd SubPrivate Sub myText_MouseMove(ByValButton As Integer, ByValShift As Integer, ByVal X As Single, ByVal Y As Single)Select Case IndexCase 3Userform2.Label2.Caption = "3"Case 8Userform2.Label2.Caption = "8"Case 4Userform2.Label2.Caption = "4"Case 9Userform2.Label2.Caption = "9"Case ElseUserform2.Label2.Caption =End SelectEnd Sub模块1代码：Public a(1 To 14) As myTextSub formshow()Userform2.ShowEnd Sub窗体代码：Private Sub CommandButton1_Click()Dim i&, t$For i = 1 To 14If a(i).myText.Text <> "" Thent = t & 控件名称："& a(i).myText.Name & vbTab & "Text 属性："&a(i).myText.Text & vbCrLfEnd IfNext iMsgBox tEnd SubPrivate Sub UserForm_Initialize()Dim i&For i = 1 To 14Set a(i) = New myTextSet a(i).myText = Me.Controls("Textbox" & i)Set a(i).frm = MeNext iEnd Sub工作表代码：Private Sub CommandButton1_Click()Userform2.Show2, 复选框选择快盘Mytb更新类类0928.xls当复选框选择到7个时，其它的复选框不能再选择。当复选框选择小于7个，其它的复 选框还能继续选择。类模块代码：Public WithEvents che As MSForms.CheckBoxPublic WithEvents frm As MSForms.UserFormPrivate Sub che_Change()'类的数据改变事件Dim index As Longindex = Mid(che.Name, 9)'取出 checkboxN 中的数字 NIf frm.Controls("checkbox" & index) = True Thena = a & Format(index, "00") & ","n = n + 1If n = 7 ThenFor i = 1 To 18b = Format(i, "00")If InStr(a, b) = 0 Thenfrm.Controls("checkbox" & i).Enabled = FalseEnd IfNextElseEnd IfElsen = n - 1a = Replace(a, Format(index, "00"),"")For i = 1 To 18frm.Controls("checkbox" & i).Enabled = TrueNextEnd IfEnd Sub模块1代码：Public newclass(1 To 18) As che 类，n&, a$Sub formshow()UserForml.ShowEnd Sub窗体代码：Private Sub UserForm_Initialize()For i = 1 To 18Set newclass(i) = New che类'创建一个新的che类对象Set newclass(i).che = Controls("checkbox" & i)'设置新类和 checkbox(i) 控件创建关键Set newclass(i).frm = Me'类窗体也和当前窗体建立关联NextEnd Sub3, 限制多个TEXTBOX的输入，使其只能输入数值快盘Mytb更新类如何限制多个TEXTBOX的输入_zhaogang1980.xls类模块代码:Public WithEvents Txtbox As MSForms.TextBoxPrivate Sub Txtbox_Change()With CreateObject(vbscript.regexp).Global = True.Pattern = 0-9.+If .test(Txtbox.Text) ThenTxtbox.Text = .Replace(Txtbox.Text,"")End IfEnd WithEnd Sub模块1代码：Sub Macro1()UserForml.ShowEnd Sub窗体代码：Dim Txt() As New clsTxtPrivate Sub UserForm_Initialize()Dim ctl As Control, m&For Each ctl In Me.ControlsIf TypeName(ctl) = "TextBox" ThenIf ctl.Name <> "TextBox1" Then m = m + 1ReDim Preserve Txt(1 To m)Set Txt(m).Txtbox = ctlEnd IfEnd IfNextEnd SubPrivate Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)'第一个不 需要类模块If TextBox1.Text = "" Then Exit SubIf IsDate(TextBox1.Text) = False ThenCancel = TrueTextBoxl.Text =End IfEnd Sub4, 限制输入字母Private WithEvents t As MSForms.TextBoxPrivate Sub t_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)'限制只可以输入数字，不可输入字母和其他符号Select Case KeyAsciiCase 48 To 57Case 46If InStr(1, t.Text, ".") ThenKeyAscii = 0End IfCase ElseKeyAscii = 0End SelectEnd SubPrivate Sub t_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)'限制中文输入With CreateObject(vbscript.regexp).Global = True.Pattern = 0-9.+If .test(t.Text) Thent.Text = .Replace(t.Text,"")End IfEnd WithEnd SubPublic Sub tk(i As OLEObject)获取oleboject对象Set t = i.ObjectEnd SubDim Ar(1 To 100) As TT'定义数组类Sub justest()Dim j As OLEObject, K As ByteFor Each j In Sheet1.OLEObjectsIf TypeName(j.Object) = "TextBox" Then'如果为TEXTBOX控件j.Object.Text = ""'清空文本框K = K + 1: Set Ar(K) = New TT'同时创建类实体Ar(K).tk j'给类实体赋值，激活事件。End Sub5, 表格上的按钮telnet_zhaogang1960。 xls'类模块clsCmd中代码：Public WithEvents Cmdbox As MSForms.CommandButtonPrivate Sub Cmdbox_Click()MsgBox Cmdbox.CaptionEnd Sub表格1上的ActiveX按钮控件Dim Cmd(1 To 3) As New clsCmdPrivate Sub Worksheet_Activate()Dim i As ByteFor i = 1 To 3Set Cmd(i).Cmdbox = Me.OLEObjects("CommandButton" & i).ObjectNextEnd SubPrivate Sub Worksheet_Deactivate()Erase CmdEnd Sub6, 求助由代码生成的控件的事件by:山菊花当光标移入某个文本框，这个文本框的背景色变为蓝色，前景改为白色类模块代码：Public WithEvents cmd As MSForms.CommandButtonPublic WithEvents mBox As MSForms.TextBoxPrivate Sub cmd_Click()Dim ctl As MSForms.ControlWith UserForm1For Each ctl In .ControlsIf TypeName(ctl) = "TextBox" ThenIf ctl.Name <> "TextBox1" Then .Controls.Remove ctl.NameElself TypeName(ctl) = "CommandButton" ThenIf ctl.Name <> "CommandButton1" And ctl.Name <>CommandButton2" Then .Controls.Remove ctl.NameEnd IfNext.CommandButton1.Enabled = True.CommandButton2.Enabled = FalseEnd WithEnd SubPrivate Sub mBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,ByVal X As Single, ByVal Y As Single)For i = 2 To 4With UserForm1.Controls("TextBox" & i).ForeColor = 0.BackColor = 16777215mBox.BackColor = 16711680mBox.ForeColor = 16777215End Sub窗体代码：Private d(1 To 4) As New cmd_ClassPrivate Sub CommandButton1_Click()For i = 1 To 3Set d(i).mBox = Frame1.Controls.Add(forms.TextBox.1，True)With d(i).mBox.Left = 10.Top = (i - 1) * 30 + 3.Width = 70.Height = 20.Text = .NameSet d(4).cmd = Me.Controls.Add(forms.CommandButton.1，True)With d(4).cmd.Left = CommandButton2.Left.Top = CommandButton2.Top + CommandButton2.Height.Width = CommandButton2.Width.Height = CommandButton2.Height.Caption = 删除End WithCommandButton1.Enabled = FalseCommandButton2.Enabled = TrueEnd SubPrivate Sub CommandButton2_Click()For i = 2 To 4With Controls("TextBox" & i)TextBox1.Value = Val(TextBox1.Value) + Val(.Value).ForeColor = 0.BackColor = 16777215End WithNextEnd Sub7，窗体键盘快盘Mytb更新类可否实现窗体键盘.xls模块1代码：Public sName As String类模块CmdArray代码：Public WithEvents cmd As MSForms.CommandButtonPrivate Sub cmd_Click()UserForm1.Controls(sName).Text = UserForm1.Controls(sName).Text & cmd.CaptionEnd Sub类模块TxtArray代码:Public WithEvents txt As MSForms.TextBoxPrivate Sub txt_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,ByVal X As Single, ByVal Y As Single)sName = txt.NameEnd Sub窗体代码：Private arrCmd(0 To 10) As CmdArrayPrivate arrTxt(1 To 4) As TxtArrayPrivate Sub UserForm_Initialize()Dim i As IntegerDim cmdNew As CmdArrayDim txtNew As TxtArrayFor i = 0 To 10Set cmdNew = New CmdArraySet cmdNew.cmd = Me.Controls("CommandButton" & i)Set arrCmd(i) = cmdNewSet cmdNew = NothingNextFor i = 1 To 4Set txtNew = New TxtArraySet txtNew.txt = Me.Controls("TextBox" & i)Set arrTxt(i) = txtNewSet txtNew = NothingNextEnd Sub8，横道图快盘Mytb更新类类入门横道图_a371014988.xls模块1代码：Sub画线条()Dim st As Worksheet, arr As Range, tg As RangeSet st = Sheets("横道图)Set arr = st.Range("A5:A" & st.Range(A65536).End(xlUp).Row)For Each tg In arrDim Li As New 类 1Li.SDate = DateValue(tg.Offset(0, 3)Li.Edate = DateValue(tg.Offset(0, 4)Li.st = stLi.target = tgLi.arr = st.Range(Cells(2, 7), st.Cells(2, 255).End(xlToLeft)If Li.line Then Debug.Print tgNextEnd Sub类模块类1代码：'取左Private m_st As WorksheetPrivate M_SDate As DatePrivate M_EDate As DatePrivate M_target As RangePrivate M_arr As RangeConst Height As Integer = 3Public Property GetEdate() As DateEdate = M_EDateEnd PropertyPublic Property LetEdate(value As Date)M_EDate = valueEnd PropertyPublic Property GetSDate() As DateSDate = M_SDateEnd PropertyPublic Property LetSDate(value As Date)M_SDate = valueEnd PropertyPublic Property Getst() As WorksheetSet st = m_stEnd PropertyPublic Property Let st(stvalue As Worksheet)Set m_st = stvalueEnd PropertyPublic Property Get target() As RangeSet target = M_targetEnd PropertyPublic Property Let target(tgvalue As Range)Set M_target = tgvalueEnd PropertyPublic Property Get arr() As RangeSet arr = M_arrEnd PropertyPublic Property Let arr(value As Range)Set M_arr = valueEnd PropertyPublic Function GetDateLineLeft(ByVal StartDate As Date) As SingleDim tg As Range, StartPointLeft As Single, i As IntegerFor Each tg In arrIf IsDate(tg.value) ThenIf Year(StartDate) = Year(tg.value) And Month(StartDate) =Month(tg.value) Then'If DateValue(Year(StartDate) &"-" & Month(StartDate) &"-" &"1")=DateValue(tg.Value) ThenDebug.Print Day(StartDate)Select Case CInt(Day(StartDate)Case Is < CInt(tg.Offset(1, 0)For i = 1 To tg.Offset(1, 0).Column - 1StartPointLeft = StartPointLeft +st.Columns(i).WidthNext iGetDateLineLeft = StartPointLeft +(CInt(Day(StartDate) Mod 10) * st.Columns(tg.Offset(1, 0).Column).Width / 10Case Is = CInt(tg.Offset(1, 0)For i = 1 To tg.Offset(1, 0).ColumnStartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit FunctionCase Is < CInt(tg.Offset(1, 0).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Column - 1StartPointLeft = StartPointLeft + st.Columns(i).Width Next iGetDateLineLeft = StartPointLeft + (CInt(Day(StartDate) Mod 10)* st.Columns(tg.Offset(1, 0).Offset(0,Case Is = CInt(tg.Offset(1, 0).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Columnst.Columns(i).Width1).Column - 1st.Columns(i).WidthStartPointLeftStartPointLeftNext iGetDateLineLeft = StartPointLeftExit FunctionCase Is < CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Offset(0,StartPointLeftStartPointLeftNext iGetDateLineLeftStartPointLeft(CInt(Day(StartDate) Mod 10) * 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)Case Is = CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1)For i = 1 To tg.Offset(1, 0).ColumnStartPointLeft = StartPointLeft +st.Columns(i).WidthNext iGetDateLineLeft = StartPointLeftExit FunctionEnd SelectEnd IfEnd IfNext tgEnd Function'取右顶点线条位置Public Function GetDateLineRight(ByVal EndDate As Date) As SingleDim arr As Range, tg As Range, StartPointLeft As Single, i As IntegerSet arr = st.Range(Cells(2, 7), st.Cells(2, 255).End(xlToLeft)For Each tg In arrIf IsDate(tg.value) ThenIf Year(EndDate) = Year(tg.value) And Month(EndDate) = Month(tg.value) Then'If DateValue(Year(EndDate) & 年 & Month(EndDate) & 月 & "1 日)=tg.Value ThenDebug.Print Day(EndDate)Select Case CInt(Day(EndDate)Case Is < CInt(tg.Offset(1, 0)For i = 1 To tg.Offset(1, 0).Column - 1StartPointLeft = StartPointLeft + st.Columns(i).WidthNext iGetDateLineRight = StartPointLeft +(CInt(Day(EndDate) Mod 10) * st.Columns(tg.Offset(1, 0).Column).Width / 10Exit FunctionCase Is = CInt(tg.Offset(1, 0)For i = 1 To tg.Offset(1, 0).ColumnStartPointLeft = StartPointLeft + st.Columns(i).WidthNext iGetDateLineRight = StartPointLeftCase Is < CInt(tg.Offset(1, 0).Offset(0, 1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Column -1StartPointLeft = StartPointLeft + st.Columns(i).WidthNext iGetDateLineRight = StartPointLeft + (CInt(Day(EndDate) Mod 10)* st.Columns(tg.Offset(1, 0).Offset(0,1).Column).Width / 10Exit FunctionCase Is = CInt(tg.Offset(1, 0).Offset(0, 1)StartPointLeftStartPointLeftst.Columns(i).WidthNext iGetDateLineRight = StartPointLeftExit FunctionCase Is < CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0,1)For i = 1 Totg.Offset(1, 0).Offset(0,1).Offset(0, 1).Column - 1StartPointLeftStartPointLeftst.Columns(i).WidthNext iGetDateLineRightStartPointLeft(CInt(Day(EndDate) Mod 10) * 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)Exit Function1)For i = 1 To tg.Offset(1, 0).Offset(0, 1).Offset(0, 1).ColumnStartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineRight = StartPointLeft Exit Function End Select End If End IfNext tgEnd FunctionPublic Function GetLineTop(ByVal tg As Range) As SingleDim i As Integer, LineTop As SingleFor i =1 To tg.Row - 1LineTop = LineTop + st.Rows(i).HeightNext iGetLineTop = LineTop + tg.Height / 3End FunctionPublic Function GetLineHeight()GetLineHeight = HeightEnd FunctionPublic Function line() As Booleanst.Shapes.AddShape(msoShapeRectangle,GetDateLineLeft(SDate),GetLineTop(target), GetDateLineRight(Edate) - GetDateLineLeft(SDate),GetLineHeight).SelectSelection.ShapeRange.line.ForeColor.RGB = RGB(255, 0, 0)Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)End Function工作表按钮代码：Private Sub CommandButton1_Click()Application.Run 画线条End SubPrivate Sub CommandButton2_Click()For Each obj In Me.ShapesIf obj.Name = "CommandButton1" Or obj.Name = "CommandButton2" ThenElseobj.DeleteEnd IfNextEnd Sub9，类模块入门_ExcelPerfect这里简单地介绍VBA中的类模块，使大家能够在应用程序中创建并使用简单的类。类是对象的“模板”。对象可以是任何事物，而类不会做任何事情，也不会占用内存，只 有当类成为对象并使用Set语句和New关键字实例化为具体对象后，才能做事情并占用内 存。实例化类为具体对象的语法为：Dim C As Class1Set C=New Classi上述语句创建了一个名为C的对象，该对象的数据类型为定义的类Classi。在详细介绍类之前，让我们先看看VBA的用户自定义数据类型，即使用Type关键字定义的变量。例如，下面的Type变量定义了雇员的信息：Type EmployeeName As StringAddress As StringSalary As DoubleEnd Type上面的语句定义了变量Employee，包含元素Name、Address和Salary。接着，您可以声明一个Employee型的变量，并为其中的每个元素赋值：Sub test()Dim Fan As EmployeeFan.Name = "fanjy"Fan.Address = "YiChang"Fan.Salary =1000End Sub用户自定义类型是很有用的，但是有三个主要的局限：1、在编译时必须声明所有的自定义类型变量。虽然可以使用动态数组来处理多个自定义类 型，但必须使用Redim Preserve关键词。并且，不能在运行时添加新的自定义类型变量。2、不能控制赋给自定义类型中元素的值。例如，在上述代码中，有可能给Salary元素赋 一个负值。3、自定义类型不做任何事情，只是静态地存储数据。用户自定义类型被广泛用于在对Windows API函数调用时，除此之外，使用类模块是更好 的选择。类克服了用户自定义类型的局限。1、使用New关键字，可以创建任意数量的类的新实例，并且能够将其存储在Collection 对象中。2、使用Property Let/Set/Get语句，可以编写代码验证赋给类元素的值，并且可以编写 当值改变时执行的相应代码。例如，能够编写代码确保Salary的值不为负值。3、类可以定义方法（使用Sub过程和Function过程），执行某项动作。