Excel-VBA-类代码实例集锦.doc

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) Then frm.Label1.Caption = 控件事件：Change & vbCrLf & _ 控件名称： & frm.Controls(Textbox & Index).Name & vbCrLf & _ Text属性： & frm.Controls(Textbox & Index).TextEnd IfEnd SubPrivate Sub myText_DblClick(ByVal Cancel As MSForms.ReturnBoolean)Index = Mid(myText.Name, 8)If frm.Controls(Textbox & Index) Then frm.Label1.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.Label1.Caption = 控件事件：KeyUp & vbCrLf & _ 控件名称： & frm.Controls(Textbox & Index).Name & vbCrLf & _ 按键值：&H & Hex$(KeyCode)End IfEnd SubPrivate Sub myText_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)Select Case IndexCase 3 Userform2.Label2.Caption = 3Case 8Userform2.Label2.Caption = 8Case 4 Userform2.Label2.Caption = 4Case 9 Userform2.Label2.Caption = 9Case Else Userform2.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 14 If a(i).myText.Text Then t = t & 控件名称： & a(i).myText.Name & vbTab & Text属性： & a(i).myText.Text & vbCrLf End IfNext iMsgBox tEnd SubPrivate Sub UserForm_Initialize()Dim i&For i = 1 To 14 Set a(i) = New myText Set a(i).myText = Me.Controls(Textbox & i) Set a(i).frm = MeNext iEnd Sub工作表代码：Private Sub CommandButton1_Click()Userform2.ShowEnd Sub2, 复选框选择 快盘Mytb更新类类0928.xls当复选框选择到7个时，其它的复选框不能再选择。当复选框选择小于7个，其它的复选框还能继续选择。类模块代码：Public WithEvents che As MSForms.CheckBoxPublic WithEvents frm As MSForms.UserFormPrivate Sub che_Change() 类的数据改变事件 Dim index As Long index = Mid(che.Name, 9) 取出checkboxN中的数字N If frm.Controls(checkbox & index) = True Then a = a & Format(index, 00) & , n = n + 1 If n = 7 Then For i = 1 To 18 b = Format(i, 00) If InStr(a, b) = 0 Then frm.Controls(checkbox & i).Enabled = False End If Next Else End If Else n = n - 1 a = Replace(a, Format(index, 00), ) For i = 1 To 18 frm.Controls(checkbox & i).Enabled = True Next End IfEnd Sub模块1代码：Public newclass(1 To 18) As che类, n&, a$Sub formshow()UserForm1.ShowEnd Sub窗体代码：Private Sub UserForm_Initialize() For i = 1 To 18 Set newclass(i) = New che类 创建一个新的che类对象 Set newclass(i).che = Controls(checkbox & i) 设置新类和checkbox(i)控件创建关键 Set newclass(i).frm = Me 类窗体也和当前窗体建立关联 Next End Sub3, 限制多个TEXTBOX的输入，使其只能输入数值 快盘Mytb更新类如何限制多个TEXTBOX的输入_zhaogang1980.xls/thread-956447-1-1.html类模块代码：Public WithEvents Txtbox As MSForms.TextBoxPrivate Sub Txtbox_Change() With CreateObject(vbscript.regexp) .Global = True .Pattern = 0-9.+ If .test(Txtbox.Text) Then Txtbox.Text = .Replace(Txtbox.Text, ) End If End WithEnd Sub模块1代码：Sub Macro1()UserForm1.ShowEnd Sub窗体代码：Dim Txt() As New clsTxtPrivate Sub UserForm_Initialize() Dim ctl As Control, m& For Each ctl In Me.Controls If TypeName(ctl) = TextBox Then If ctl.Name TextBox1 Then m = m + 1 ReDim Preserve Txt(1 To m) Set Txt(m).Txtbox = ctl End If End If NextEnd SubPrivate Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) 第一个不需要类模块 If TextBox1.Text = Then Exit Sub If IsDate(TextBox1.Text) = False Then Cancel = True TextBox1.Text = End IfEnd Sub4，限制输入字母 /thread-28095-1-1-14725.htmlPrivate WithEvents t As MSForms.TextBoxPrivate Sub t_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)限制只可以输入数字，不可输入字母和其他符号Select Case KeyAsciiCase 48 To 57Case 46 If InStr(1, t.Text, .) Then KeyAscii = 0 End IfCase Else KeyAscii = 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) Then t.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.OLEObjects If TypeName(j.Object) = TextBox Then 如果为TEXTBOX控件 j.Object.Text = 清空文本框 K = K + 1: Set Ar(K) = New TT 同时创建类实体 Ar(K).tk j 给类实体赋值，激活事件。 End IfNextEnd 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 Byte For i = 1 To 3 Set Cmd(i).Cmdbox = Me.OLEObjects(CommandButton & i).Object NextEnd SubPrivate Sub Worksheet_Deactivate() Erase CmdEnd Sub6, 求助由代码生成的控件的事件 by:山菊花当光标移入某个文本框，这个文本框的背景色变为蓝色，前景改为白色/thread-1187834-1-1.html类模块代码：Public WithEvents cmd As MSForms.CommandButtonPublic WithEvents mBox As MSForms.TextBoxPrivate Sub cmd_Click() Dim ctl As MSForms.Control With UserForm1 For Each ctl In .Controls If TypeName(ctl) = TextBox Then If ctl.Name TextBox1 Then .Controls.Remove ctl.Name ElseIf TypeName(ctl) = CommandButton Then If ctl.Name CommandButton1 And ctl.Name CommandButton2 Then .Controls.Remove ctl.Name End If Next .CommandButton1.Enabled = True .CommandButton2.Enabled = False End With End SubPrivate Sub mBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) For i = 2 To 4 With UserForm1.Controls(TextBox & i) .ForeColor = 0 .BackColor = 16777215 End With Next mBox.BackColor = 16711680 mBox.ForeColor = 16777215End Sub窗体代码：Private d(1 To 4) As New cmd_ClassPrivate Sub CommandButton1_Click() For i = 1 To 3 Set 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 = .Name End With Next i Set 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 With CommandButton1.Enabled = False CommandButton2.Enabled = TrueEnd SubPrivate Sub CommandButton2_Click() For i = 2 To 4 With Controls(TextBox & i) TextBox1.Value = Val(TextBox1.Value) + Val(.Value) .ForeColor = 0 .BackColor = 16777215 End With NextEnd 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 Integer Dim cmdNew As CmdArray Dim txtNew As TxtArray For i = 0 To 10 Set cmdNew = New CmdArray Set cmdNew.cmd = Me.Controls(CommandButton & i) Set arrCmd(i) = cmdNew Set cmdNew = Nothing Next For i = 1 To 4 Set txtNew = New TxtArray Set txtNew.txt = Me.Controls(TextBox & i) Set arrTxt(i) = txtNew Set txtNew = Nothing NextEnd Sub8，横道图 快盘Mytb更新类类入门横道图_a371014988.xls模块1代码：Sub 画线条() Dim st As Worksheet, arr As Range, tg As Range Set st = Sheets(横道图) Set arr = st.Range(A5:A & st.Range(A65536).End(xlUp).Row) For Each tg In arr Dim Li As New 类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) If Li.line Then Debug.Print tg NextEnd 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 Get Edate() As Date Edate = M_EDateEnd PropertyPublic Property Let Edate(value As Date) M_EDate = valueEnd PropertyPublic Property Get SDate() As Date SDate = M_SDateEnd PropertyPublic Property Let SDate(value As Date) M_SDate = valueEnd PropertyPublic Property Get st() As Worksheet Set st = m_stEnd PropertyPublic Property Let st(stvalue As Worksheet) Set m_st = stvalueEnd PropertyPublic Property Get target() As Range Set target = M_targetEnd PropertyPublic Property Let target(tgvalue As Range) Set M_target = tgvalueEnd PropertyPublic Property Get arr() As Range Set arr = M_arrEnd PropertyPublic Property Let arr(value As Range) Set M_arr = valueEnd PropertyPublic Function GetDateLineLeft(ByVal StartDate As Date) As Single Dim tg As Range, StartPointLeft As Single, i As Integer For Each tg In arr If IsDate(tg.value) Then If Year(StartDate) = Year(tg.value) And Month(StartDate) = Month(tg.value) Then If DateValue(Year(StartDate) & - & Month(StartDate) & - & 1) = DateValue(tg.Value) Then Debug.Print Day(StartDate) Select Case CInt(Day(StartDate) Case Is CInt(tg.Offset(1, 0) For i = 1 To tg.Offset(1, 0).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft + (CInt(Day(StartDate) Mod 10) * st.Columns(tg.Offset(1, 0).Column).Width / 10 Exit Function Case Is = CInt(tg.Offset(1, 0) For i = 1 To tg.Offset(1, 0).Column StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit Function Case Is CInt(tg.Offset(1, 0).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Offset(0, 1).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft + (CInt(Day(StartDate) Mod 10) * st.Columns(tg.Offset(1, 0).Offset(0, 1).Column).Width / 10 Exit Function Case Is = CInt(tg.Offset(1, 0).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Column StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit Function Case 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, 1).Column - 1 StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft + (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) Exit Function Case Is = CInt(tg.Offset(1, 0).Offset(0, 1).Offset(0, 1) For i = 1 To tg.Offset(1, 0).Column StartPointLeft = StartPointLeft + st.Columns(i).Width Next i GetDateLineLeft = StartPointLeft Exit Function End Select End If End If Next tgEnd Function取右顶点线条位置Public Function GetDateLineRight(ByVal EndDate As Date) As Single Dim arr As Range, tg As Range, StartPointLeft As Single, i As Integer Set arr = st.Range(Cells(2, 7), st.Cells(2, 255).End(xlToLeft) For Each tg In arr If IsDate(tg.value) Then If Year(EndDate) = Year(tg.value) And Month(EndDate) = Month(tg.value) Then If DateValue(Year(EndDate) & 年 & Month(EndDate) & 月 & 1日) = tg.Value Then Debug.Print Day(EndDate) Select Case CInt(Day(EndDate) Case Is CInt(tg.Offset(1, 0) For i = 1 To tg.