第6章-控件与用户窗体代码【超实用VBA

1、第6章 控件与用户窗体范例67 文本框只能输入数值Private Sub TextBox1_KeyPress(ByVal KeyANSI As MSForms.ReturnInteger) With TextBox1 Select Case KeyANSI Case Asc(0) To Asc(9) Case Asc(-) If InStr(1, .Text, -) 0 Or .SelStart 0 Then KeyANSI = 0 End If Case Asc(.) If InStr(1, .Text, .) 0 Then KeyANSI = 0 Case Else KeyANSI = 0

2、 End Select End WithEnd SubPrivate Sub TextBox1_Change() Dim i As Integer Dim Str As String With TextBox1 For i = 1 To Len(.Text) Str = Mid(.Text, i, 1) Select Case Str Case ., -, 0 To 9 Case Else .Text = Replace(.Text, Str, ) End Select Next End WithEnd Sub范例68 限制文本框的输入长度Private Sub TextBox1_Change

3、() TextBox1.MaxLength = 6End Sub范例69 验证文本框输入的数据Private Sub CommandButton1_Click() With TextBox1 If (Len(Trim(.Text) = 15 Or (Len(Trim(.Text) = 18 Then Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = .Text Else MsgBox 身份证号码错误，请重新输入! End If .Text = .SetFocus End WithEnd Sub范例70 文本框回车自动输入Private Sub Text

4、Box1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim r As Integer r = Cells(Rows.Count, 1).End(xlUp).Row With TextBox1 If Len(Trim(.Text) 0 And KeyCode = vbKeyReturn Then Cells(r + 1, 1) = .Text .Text = End If End WithEnd Sub范例71 文本框的自动换行Private Sub UserForm_Initialize()

5、With TextBox1 .WordWrap = True .MultiLine = True .Text = 文本框是一个灵活的控件，受下列属性的影响：Text、 _ & MultiLine、WordWrap和AutoSize。 & vbCrLf _ & Text 包含显示在文本框中的文本。 & vbCrLf _ & MultiLine 控制文本框是单行还是多行显示文本。 _ & 换行字符用于标识在何处结束一行并开始新的一行。 _ & 如果 MultiLine 的值为False，则文本将被截断， _ & 而不会换行。如果文本的长度大于文本框的宽度， _ & WordWrap允许文本框根据其

6、宽度自动换行。 & vbCrLf _ & 如果不使用 WordWrap，当文本框在文本中遇到换行字符时， _ & 开始一个新行。如果关闭WordWrap，TextBox中可以有不能 _ & 完全适合其宽度的文本行。文本框根据该宽度，显示宽度以 _ & 内的文本部分，截断宽度以外的那文本部分。只有当 _ & MultiLine为True时，WordWrap才起作用。 & vbCrLf _ & AutoSize 控制是否调节文本框的大小，以便显示所有文本。 _ & 当文本框使用AutoSize 时，文本框的宽度按照文本框中的 _ & 文字量以及显示该文本的字体大小收缩或扩大。 End WithEn

7、d Sub范例72 格式化文本框数据Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, #,#0.00)End SubPrivate Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox2 = Format(TextBox2, #,#0.00)End Sub范例73 使控件始终位于可视区域Private Sub Worksheet_SelectionChange(ByVal Target

8、 As Range) Dim rng As Range Set rng = ActiveWindow.VisibleRange.Cells(1) With CommandButton1 .Top = rng.Top .Left = rng.Left End With With CommandButton2 .Top = rng.Top .Left = rng.Left + CommandButton1.Width End With Set rng = NothingEnd Sub范例74 高亮显示按钮控件Private Sub CommandButton1_MouseMove(ByVal Bu

9、tton As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) With Me.CommandButton1 .BackColor = &HFFFF00 .Width = 62 .Height = 62 .Top = 69 .Left = 31 End WithEnd SubPrivate Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Singl

10、e) With Me.CommandButton1 .BackColor = Me.BackColor .Width = 60 .Height = 60 .Top = 70 .Left = 32 End WithEnd Sub范例75 列表框添加列表项的方法75-1 使用RowSource属性Private Sub UserForm_Initialize() Dim r As Integer r = Sheet3.Range(A).End(xlUp).Row ListBox1.RowSource = Sheet3!a1:a & rEnd Sub75-2 使用ListFillRange属性Sub

11、 ListFillRange() Dim r As Integer r = Sheet3.Range(A).End(xlUp).Row Sheet1.ListBox1.ListFillRange = Sheet3!a1:a & r Sheet1.Shapes(列表框).ControlFormat.ListFillRange = Sheet3!a1:a & rEnd Sub75-3 使用List属性Private Sub UserForm_Initialize() Dim arr As Variant Dim r As Integer r = Sheet3.Range(A).End(xlUp).

12、Row arr = Sheet3.Range(A1:A & r) ListBox1.List = arrEnd SubSub List() Dim arr As Variant Dim r As Integer Dim MyObj As Object r = Sheet3.Range(A).End(xlUp).Row arr = Sheet3.Range(A1:A & r) Set MyObj = Sheet2.Shapes(列表框).ControlFormat MyObj.List = arr Set MyObj = NothingEnd Sub75-4 使用AddItem方法Private

13、 Sub UserForm_Initialize() Dim r As Integer Dim i As Integer r = Sheet3.Range(A).End(xlUp).Row For i = 1 To r ListBox1.AddItem (Sheet3.Cells(i, 1) NextEnd SubSub AddItem() Dim r As Integer Dim i As Integer r = Sheet3.Range(A).End(xlUp).Row With Sheet2.Shapes(列表框).ControlFormat .RemoveAllItems For i

14、= 1 To r .AddItem Sheet3.Cells(i, 1) Next End WithEnd Sub范例76 去除列表项的空行和重复项Private Sub UserForm_Initialize() Dim r As Integer Dim i As Integer Dim MyCol As New Collection Dim arr() As Variant On Error Resume Next With Sheet1 r = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 1 To r If Trim(.Cells(i, 1)

15、 Then MyCol.Add Item:=Cells(i, 1), key:=CStr(.Cells(i, 1) End If Next End With ReDim arr(1 To MyCol.Count) For i = 1 To MyCol.Count arr(i) = MyCol(i) Next ListBox1.List = arrEnd Sub范例77 移动列表框的列表项Private Sub CommandButton1_Click() Dim Ind As Integer Dim Str As String With Me.ListBox1 Ind = .ListIndex

16、 Select Case Ind Case -1 MsgBox 请选择一行后再移动! Case 0 MsgBox 已经是第一行了! Case Is 0 Str = .List(Ind) .List(Ind) = .List(Ind - 1) .List(Ind - 1) = Str .ListIndex = Ind - 1 End Select End WithEnd SubPrivate Sub CommandButton2_Click() Dim Ind As Integer Dim Str As String With ListBox1 Ind = .ListIndex Select C

17、ase Ind Case -1 MsgBox 请选择一行后再移动! Case .ListCount - 1 MsgBox 已经是最后下一行了! Case Is .ListCount - 1 Str = .List(Ind) .List(Ind) = .List(Ind + 1) .List(Ind + 1) = Str .ListIndex = Ind + 1 End Select End WithEnd SubPrivate Sub CommandButton3_Click() Dim i As Integer For i = 1 To ListBox1.ListCount Cells(i,

18、 1) = ListBox1.List(i - 1) NextEnd Sub范例78 允许多项选择的列表框Private Sub UserForm_Initialize() Dim arr As Variant arr = Array(经理室, 办公室, 生技科, 财务科, 营业部, 制水车间, 污水厂, 其他) With Me.ListBox1 .List = arr .MultiSelect = 1 .ListStyle = 1 End WithEnd SubPrivate Sub CommandButton1_Click() Dim i As Integer Dim Str As Str

19、ing For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then Str = Str & ListBox1.List(i) & Chr(13) End If Next If Str Then MsgBox Str Else MsgBox 至少需要选择一个部门! End IfEnd Sub范例79 多列列表框的设置Private Sub UserForm_Initialize() Dim r As Integer With Sheet3 r = .Cells(.Rows.Count, 1).End(xlUp).

20、Row - 1 End With With ListBox1 .ColumnCount = 7 .ColumnWidths = 35,45,45,45,45,40,50 .BoundColumn = 1 .ColumnHeads = True .TextAlign = 3 .RowSource = Sheet3.Range(A2:G & r).Address(External:=True) End WithEnd SubPrivate Sub ListBox1_Click() Dim r As Integer Dim i As Integer With Sheet1 r = .Cells(.R

21、ows.Count, 1).End(xlUp).Row + 1 For i = 1 To ListBox1.ColumnCount .Cells(r, i) = ListBox1.Column(i - 1) Next End WithEnd Sub范例80 二级组合框Private Sub UserForm_Initialize() Dim r As Integer Dim MyCol As New Collection Dim arr() As Variant Dim rng As Range Dim i As Integer On Error Resume Next r = Cells(R

22、ows.Count, 1).End(xlUp).Row For Each rng In Range(A2:A & r) MyCol.Add rng, CStr(rng) Next ReDim arr(1 To MyCol.Count) For i = 1 To MyCol.Count arr(i) = MyCol(i) Next ComboBox1.List = arr ComboBox1.ListIndex = 0 Set MyCol = Nothing Set rng = NothingEnd SubPrivate Sub ComboBox1_Change() Dim MyAddress

23、As String Dim rng As Range ComboBox2.Clear With Sheet1.Range(A:A) Set rng = .Find(What:=ComboBox1.Text) If Not rng Is Nothing Then MyAddress = rng.Address Do ComboBox2.AddItem rng.Offset(, 1) Set rng = .FindNext(rng) Loop While Not rng Is Nothing And rng.Address MyAddress End If End With ComboBox2.L

24、istIndex = 0 Set rng = NothingEnd Sub范例81 使用RefEdit控件选择区域Private Sub CommandButton1_Click() Dim rng As Range On Error Resume Next Set rng = Range(RefEdit1.Value) rng.Interior.ColorIndex = 16 Set rng = NothingEnd Sub范例82 使用多页控件Private Sub UserForm_Initialize() MultiPage1.Value = 0End SubPrivate Sub M

25、ultiPage1_Change() If MultiPage1.SelectedItem.Index 0 Then MsgBox 您选择的是 & MultiPage1.SelectedItem.Caption & 页面! End IfEnd Sub范例83 使用TabStrip控件Private Sub UserForm_Initialize() TabStrip1.Value = 0 TabStrip1.Style = 0End SubPrivate Sub TabStrip1_Change() Dim str As String Dim FilPath As String str = T

26、abStrip1.SelectedItem.Caption FilPath = ThisWorkbook.Path & & str & .jpg Image1.Picture = LoadPicture(FilPath) Label1.Caption = str & 欢迎您!End Sub范例84 在框架中使用滚动条Private Sub UserForm_Initialize() With Frame1 .ScrollBars = 3 .ScrollHeight = Image1.Height .ScrollWidth = Image1.Width End WithEnd Sub范例85 制

27、作进度条Sub myProgressBar() Dim r As Integer Dim i As Integer With Sheet1 r = .Cells(.Rows.Count, 1).End(xlUp).Row UserForm1.Show 0 With UserForm1.ProgressBar1 .Min = 1 .Max = r .Scrolling = 0 End With For i = 1 To r .Cells(i, 3) = Round(.Cells(i, 1) * .Cells(i, 2), 2) Application.Goto Reference:=.Cells

28、(i, 1), Scroll:=True UserForm1.ProgressBar1.Value = i UserForm1.Caption = 程序正在运行,已完成 & Format(i / r) * 100, 0.00) & %,请稍候! Next End With Unload UserForm1End Sub范例86 使用DTP控件输入日期Private Sub Worksheet_SelectionChange(ByVal Target As Range) With Me.DTPicker1 If Target.Count = 1 And Target.Column = 1 And

29、 Not Target.Row = 1 Or Target.MergeCells Then .Visible = True .Top = Selection.Top .Left = Selection.Left .Height = Selection.Height .Width = Selection.Width If Target.Cells(1, 1) Then .Value = Target.Cells(1, 1).Value Else .Value = Date End If Else .Visible = False End If End WithEnd SubPrivate Sub

30、 Worksheet_Change(ByVal Target As Range) If Target.Count = 1 And Target.Column = 1 Or Target.MergeCells Then If Target.Cells(1, 1).Value = Then DTPicker1.Visible = False End If End IfEnd SubPrivate Sub DTPicker1_CloseUp() ActiveCell.Value = Me.DTPicker1.Value Me.DTPicker1.Visible = FalseEnd Sub范例87

31、使用spreadsheet控件Private Sub UserForm_Initialize() Dim r As Integer Dim arr As Variant Dim i As Integer With Sheet3 r = .Cells(.Rows.Count, 1).End(xlUp).Row arr = .Range(A1:G & r) End With With Me.Spreadsheet1 .DisplayToolbar = False .DisplayWorkbookTabs = False .DisplayHorizontalScrollBar = False .Di

32、splayVerticalScrollBar = True .Rows.RowHeight = 15 .Columns.ColumnWidth = 8 With .Range(A1:G & r) .Value = arr .HorizontalAlignment = -4108 .Borders.LineStyle = xlContinuous .Borders.ColorIndex = 10 .NumberFormat = 0.00 End With End WithEnd SubPrivate Sub CommandButton1_Click() Dim r As Integer Dim

33、arr As Variant With Me.Spreadsheet1 r = .Cells(.Rows.Count, 1).End(xlUp).Row arr = .Range(A1:G & r) Sheet1.Range(A1:G & r) = arr End With Unload MeEnd SubSub RegWriteProc() Dim WshShell Set WshShell = CreateObject(Wscript.Shell) WshShell.RegWrite HKCUSoftwareMicrosoftOfficeCommonSecurityUFIControls,

34、 1, REG_DWORD WshShell.RegWrite HKCUSoftwareMicrosoftVBASecurityLoadControlsInForms, 1, REG_DWORD Set WshShell = NothingEnd Sub范例88 使用TreeView控件显示层次Private Sub UserForm_Initialize() Dim c As Integer Dim r As Integer Dim rng As Variant rng = Sheet2.UsedRange With TreeView1 .Style = tvwTreelinesPlusMi

35、nusPictureText .LineStyle = tvwRootLines .CheckBoxes = False With .Nodes .Clear .Add Key:=科目, Text:=科目名称 For c = 1 To Sheet2.UsedRange.Columns.Count For r = 2 To Sheet2.UsedRange.Rows.Count If Not IsEmpty(rng(r, c) Then If c = 1 Then .Add relative:=科目, Relationship:=tvwChild, Key:=rng(r, c), Text:=r

36、ng(r, c) ElseIf Not IsEmpty(rng(r, c - 1) Then .Add relative:=rng(r, c - 1), Relationship:=tvwChild, Key:=rng(r, c), Text:=rng(r, c) Else .Add relative:=CStr(Sheet2.Cells(r, c - 1).End(xlUp), Relationship:=tvwChild, Key:=rng(r, c), Text:=rng(r, c) End If End If Next Next End With End WithEnd SubPriv

37、ate Sub TreeView1_DblClick() Dim r As Integer With Sheet1 r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 If TreeView1.SelectedItem.Children = 0 Then .Range(A & r) = TreeView1.SelectedItem.Text Else MsgBox 您所选择的不是末级科目,请重新选择! End If End WithEnd Sub范例89 使用Listview控件89-1 使用Listview控件显示数据列表Private Sub User

38、Form_Initialize() Dim Itm As ListItem Dim r As Integer Dim i As Integer Dim c As Integer r = Cells(Rows.Count, 1).End(xlUp).Row With ListView1 .ColumnHeaders.Add , , 人员编号 , 50, 0 .ColumnHeaders.Add , , 技能工资 , 50, 1 .ColumnHeaders.Add , , 岗位工资 , 50, 1 .ColumnHeaders.Add , , 工龄工资 , 50, 1 .ColumnHeader

39、s.Add , , 浮动工资 , 50, 1 .ColumnHeaders.Add , , 其他 , 50, 1 .ColumnHeaders.Add , , 应发合计, 50, 1 .View = lvwReport .Gridlines = True For i = 2 To r Set Itm = .ListItems.Add() Itm.Text = Space(2) & Cells(i, 1) For c = 1 To 6 Itm.SubItems(c) = Format(Cells(i, c + 1), #,#,0.00) Next Next End With Set Itm =

40、NothingEnd Sub89-2 在Listview控件中使用复选框Private Sub UserForm_Initialize() Dim Itm As ListItem Dim r As Integer Dim i As Integer Dim c As Integer r = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row With ListView1 .ColumnHeaders.Add , , 人员编号 , 50, 0 .ColumnHeaders.Add , , 技能工资 , 50, 1 .ColumnHeaders.Add

41、, , 岗位工资 , 50, 1 .ColumnHeaders.Add , , 工龄工资 , 50, 1 .ColumnHeaders.Add , , 浮动工资 , 50, 1 .ColumnHeaders.Add , , 其他 , 50, 1 .ColumnHeaders.Add , , 应发合计, 50, 1 .View = lvwReport .Gridlines = True .FullRowSelect = True .CheckBoxes = True For i = 2 To r - 1 Set Itm = .ListItems.Add() Itm.Text = Sheet2.C

42、ells(i, 1) For c = 1 To 6 Itm.SubItems(c) = Format(Sheet2.Cells(i, c + 1), #,#,0.00) Next Next End With Set Itm = NothingEnd SubPrivate Sub CommandButton1_Click() Dim r As Integer Dim i As Integer Dim c As Integer r = Cells(Rows.Count, 1).End(xlUp).Row If r 1 Then Range(A2:G & r).ClearContents With

43、ListView1 For i = 1 To .ListItems.Count If .ListItems(i).Checked Then Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = .ListItems(i) For c = 1 To 6 Cells(Rows.Count, c + 1).End(xlUp).Offset(1, 0) = .ListItems(i).SubItems(c) Next End If Next End WithEnd Sub89-3 调整Listview控件的行距Private Sub UserForm_Initia

44、lize() Dim Itm As ListItem Dim i As Integer Dim c As Integer Dim Img As ListImage With ListView1 .ColumnHeaders.Add , , 人员编号 , 50, 0 .ColumnHeaders.Add , , 技能工资 , 50, 1 .ColumnHeaders.Add , , 岗位工资 , 50, 1 .ColumnHeaders.Add , , 工龄工资 , 50, 1 .ColumnHeaders.Add , , 浮动工资 , 50, 1 .ColumnHeaders.Add , , 其他 , 50, 1 .ColumnHeaders.Add , , 应发合计, 5