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

第6章控件与用户窗体范例67 文本框只能输入数值Private Sub TextBox1_KeyPress(ByVal KeyANSI As MSForms.ReturnInteger) With TextBox1Select Case KeyANSICase Asc("0") To Asc("9")Case Asc("-")If InStr(1, .Text, "-") > 0 Or .SelStart > 0 ThenKeyANSI = 0End IfCase Asc(".")If InStr(1, .Text, ".") > 0 Then KeyANSI = 0Case ElseKeyANSI = 0End SelectEnd WithEnd SubPrivate Sub TextBox1_Change()Dim i As IntegerDim Str As StringWith TextBox1For i = 1 To Len(.Text)Str = Mid(.Text, i, 1)Select Case StrCase ".", "-", "0" To "9"Case Else.Text = Replace(.Text, Str, "")End SelectNextEnd WithEnd Sub范例68 限制文本框的输入长度Private Sub TextBox1_Change()TextBox1.MaxLength = 6End Sub范例69 验证文本框输入的数据Private Sub CommandButton1_Click()With TextBox1If (Len(Trim(.Text))) = 15 Or (Len(Trim(.Text))) = 18 ThenCells(Rows.Count, 1).End(xlUp).Offset(1, 0) = .TextElseMsgBox "身份证号码错误，请重新输入!"End If.Text = "".SetFocusEnd WithEnd Sub范例70 文本框回车自动输入Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)Dim r As Integerr = Cells(Rows.Count, 1).End(xlUp).RowWith TextBox1If Len(Trim(.Text)) > 0 And KeyCode = vbKeyReturn ThenCells(r + 1, 1) = .Text.Text = ""End IfEnd WithEnd Sub范例71 文本框的自动换行Private Sub UserForm_Initialize()With TextBox1.WordWrap = True.MultiLine = True.Text = "文本框是一个灵活的控件，受下列属性的影响：Text、" _& "MultiLine、WordWrap和AutoSize。

" & vbCrLf _& "Text 包含显示在文本框中的文本。

" & vbCrLf _& "MultiLine 控制文本框是单行还是多行显示文本。

" _& "换行字符用于标识在何处结束一行并开始新的一行。

" _& "如果MultiLine 的值为False，则文本将被截断，" _& "而不会换行。

如果文本的长度大于文本框的宽度，" _& "WordWrap允许文本框根据其宽度自动换行。

" & vbCrLf _& "如果不使用WordWrap，当文本框在文本中遇到换行字符时，" _& "开始一个新行。

如果关闭WordWrap，TextBox中可以有不能" _& "完全适合其宽度的文本行。

文本框根据该宽度，显示宽度以" _& "内的文本部分，截断宽度以外的那文本部分。

只有当" _& "MultiLine为True时，WordWrap才起作用。

" & vbCrLf _& "AutoSize 控制是否调节文本框的大小，以便显示所有文本。

" _& "当文本框使用AutoSize 时，文本框的宽度按照文本框中的" _& "文字量以及显示该文本的字体大小收缩或扩大。

"End WithEnd 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 As Range) Dim rng As RangeSet rng = ActiveWindow.VisibleRange.Cells(1)With CommandButton1.Top = rng.Top.Left = rng.LeftEnd WithWith CommandButton2.Top = rng.Top.Left = rng.Left + CommandButton1.WidthEnd WithSet rng = NothingEnd Sub范例74 高亮显示按钮控件Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)With mandButton1.BackColor = &HFFFF00.Width = 62.Height = 62.Top = 69.Left = 31End WithEnd SubPrivate Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)With mandButton1.BackColor = Me.BackColor.Width = 60.Height = 60.Top = 70.Left = 32End WithEnd Sub范例75 列表框添加列表项的方法75-1 使用RowSource属性Private Sub UserForm_Initialize()Dim r As Integerr = Sheet3.Range("A1048576").End(xlUp).RowListBox1.RowSource = "Sheet3!a1:a" & rEnd Sub75-2 使用ListFillRange属性Sub ListFillRange()Dim r As Integerr = Sheet3.Range("A1048576").End(xlUp).RowSheet1.ListBox1.ListFillRange = "Sheet3!a1:a" & rSheet1.Shapes("列表框").ControlFormat.ListFillRange = "Sheet3!a1:a" & r End Sub75-3 使用List属性Private Sub UserForm_Initialize()Dim arr As VariantDim r As Integerr = Sheet3.Range("A1048576").End(xlUp).Rowarr = Sheet3.Range("A1:A" & r)ListBox1.List = arrEnd SubSub List()Dim arr As VariantDim r As IntegerDim MyObj As Objectr = Sheet3.Range("A1048576").End(xlUp).Rowarr = Sheet3.Range("A1:A" & r)Set MyObj = Sheet2.Shapes("列表框").ControlFormatMyObj.List = arrSet MyObj = NothingEnd Sub75-4 使用AddItem方法Private Sub UserForm_Initialize()Dim r As IntegerDim i As Integerr = Sheet3.Range("A1048576").End(xlUp).RowFor i = 1 To rListBox1.AddItem (Sheet3.Cells(i, 1))NextEnd SubSub AddItem()Dim r As IntegerDim i As Integerr = Sheet3.Range("A1048576").End(xlUp).RowWith Sheet2.Shapes("列表框").ControlFormat.RemoveAllItemsFor i = 1 To r.AddItem Sheet3.Cells(i, 1)NextEnd WithEnd Sub范例76 去除列表项的空行和重复项Private Sub UserForm_Initialize()Dim r As IntegerDim i As IntegerDim MyCol As New CollectionDim arr() As VariantOn Error Resume NextWith Sheet1r = .Cells(.Rows.Count, 1).End(xlUp).RowFor i = 1 To rIf Trim(.Cells(i, 1)) <> "" ThenMyCol.Add Item:=Cells(i, 1), key:=CStr(.Cells(i, 1)) End IfNextEnd WithReDim arr(1 To MyCol.Count)For i = 1 To MyCol.Countarr(i) = MyCol(i)NextListBox1.List = arrEnd Sub范例77 移动列表框的列表项Private Sub CommandButton1_Click()Dim Ind As IntegerDim Str As StringWith Me.ListBox1Ind = .ListIndexSelect Case IndCase -1MsgBox "请选择一行后再移动!"Case 0MsgBox "已经是第一行了!"Case Is > 0Str = .List(Ind).List(Ind) = .List(Ind - 1).List(Ind - 1) = Str.ListIndex = Ind - 1End SelectEnd WithEnd SubPrivate Sub CommandButton2_Click()Dim Ind As IntegerDim Str As StringWith ListBox1Ind = .ListIndexSelect Case IndCase -1MsgBox "请选择一行后再移动!"Case .ListCount - 1MsgBox "已经是最后下一行了!"Case Is < .ListCount - 1Str = .List(Ind).List(Ind) = .List(Ind + 1).List(Ind + 1) = Str.ListIndex = Ind + 1End SelectEnd WithEnd SubPrivate Sub CommandButton3_Click()Dim i As IntegerFor i = 1 To ListBox1.ListCountCells(i, 1) = ListBox1.List(i - 1)NextEnd Sub范例78 允许多项选择的列表框Private Sub UserForm_Initialize()Dim arr As Variantarr = Array("经理室", "办公室", "生技科", "财务科", "营业部", "制水车间", "污水厂", "其他")With Me.ListBox1.List = arr.MultiSelect = 1.ListStyle = 1End WithEnd SubPrivate Sub CommandButton1_Click()Dim i As IntegerDim Str As StringFor i = 0 To ListBox1.ListCount - 1If ListBox1.Selected(i) = True ThenStr = Str & ListBox1.List(i) & Chr(13)End IfNextIf Str <> "" ThenMsgBox StrElseMsgBox "至少需要选择一个部门!"End IfEnd Sub范例79 多列列表框的设置Private Sub UserForm_Initialize()Dim r As IntegerWith Sheet3r = .Cells(.Rows.Count, 1).End(xlUp).Row - 1End WithWith 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 IntegerDim i As IntegerWith Sheet1r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1For i = 1 To ListBox1.ColumnCount.Cells(r, i) = ListBox1.Column(i - 1)NextEnd WithEnd Sub范例80 二级组合框Private Sub UserForm_Initialize()Dim r As IntegerDim MyCol As New CollectionDim arr() As VariantDim rng As RangeDim i As IntegerOn Error Resume Nextr = Cells(Rows.Count, 1).End(xlUp).RowFor Each rng In Range("A2:A" & r)MyCol.Add rng, CStr(rng)NextReDim arr(1 To MyCol.Count)For i = 1 To MyCol.Countarr(i) = MyCol(i)NextComboBox1.List = arrComboBox1.ListIndex = 0Set MyCol = NothingSet rng = NothingEnd SubPrivate Sub ComboBox1_Change()Dim MyAddress As StringDim rng As RangeComboBox2.ClearWith Sheet1.Range("A:A")Set rng = .Find(What:=ComboBox1.Text)If Not rng Is Nothing ThenMyAddress = rng.AddressDoComboBox2.AddItem rng.Offset(, 1)Set rng = .FindNext(rng)Loop While Not rng Is Nothing And rng.Address <> MyAddress End IfEnd WithComboBox2.ListIndex = 0Set rng = NothingEnd Sub范例81 使用RefEdit控件选择区域Private Sub CommandButton1_Click()Dim rng As RangeOn Error Resume NextSet rng = Range(RefEdit1.Value)rng.Interior.ColorIndex = 16Set rng = NothingEnd Sub范例82 使用多页控件Private Sub UserForm_Initialize()MultiPage1.Value = 0End SubPrivate Sub MultiPage1_Change()If MultiPage1.SelectedItem.Index > 0 ThenMsgBox "您选择的是" & MultiPage1.SelectedItem.Caption & "页面!"End IfEnd Sub范例83 使用TabStrip控件Private Sub UserForm_Initialize()TabStrip1.Value = 0TabStrip1.Style = 0End SubPrivate Sub TabStrip1_Change()Dim str As StringDim FilPath As Stringstr = TabStrip1.SelectedItem.CaptionFilPath = 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.WidthEnd WithEnd Sub范例85 制作进度条Sub myProgressBar()Dim r As IntegerDim i As IntegerWith Sheet1r = .Cells(.Rows.Count, 1).End(xlUp).RowUserForm1.Show 0With UserForm1.ProgressBar1.Min = 1.Max = r.Scrolling = 0End WithFor i = 1 To r.Cells(i, 3) = Round(.Cells(i, 1) * .Cells(i, 2), 2)Application.Goto Reference:=.Cells(i, 1), Scroll:=TrueUserForm1.ProgressBar1.Value = iUserForm1.Caption = "程序正在运行,已完成" & Format((i / r) * 100, "0.00") & "%,请稍候!"NextEnd WithUnload UserForm1End Sub范例86 使用DTP控件输入日期Private Sub Worksheet_SelectionChange(ByVal Target As Range)With Me.DTPicker1If Target.Count = 1 And Target.Column = 1 And Not Target.Row = 1 Or Target.MergeCells Then.Visible = True.Top = Selection.Top.Left = Selection.Left.Height = Selection.Height.Width = Selection.WidthIf Target.Cells(1, 1) <> "" Then.Value = Target.Cells(1, 1).ValueElse.Value = DateEnd IfElse.Visible = FalseEnd IfEnd WithEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Count = 1 And Target.Column = 1 Or Target.MergeCells Then If Target.Cells(1, 1).Value = "" ThenDTPicker1.Visible = FalseEnd IfEnd IfEnd SubPrivate Sub DTPicker1_CloseUp()ActiveCell.Value = Me.DTPicker1.ValueMe.DTPicker1.Visible = FalseEnd Sub范例87 使用spreadsheet控件Private Sub UserForm_Initialize()Dim r As IntegerDim arr As VariantDim i As IntegerWith Sheet3r = .Cells(.Rows.Count, 1).End(xlUp).Rowarr = .Range("A1:G" & r)End WithWith Me.Spreadsheet1.DisplayToolbar = False.DisplayWorkbookTabs = False.DisplayHorizontalScrollBar = False.DisplayVerticalScrollBar = True.Rows.RowHeight = 15.Columns.ColumnWidth = 8With .Range("A1:G" & r).Value = arr.HorizontalAlignment = -4108.Borders.LineStyle = xlContinuous.Borders.ColorIndex = 10.NumberFormat = "0.00"End WithEnd WithEnd SubPrivate Sub CommandButton1_Click()Dim r As IntegerDim arr As VariantWith Me.Spreadsheet1r = .Cells(.Rows.Count, 1).End(xlUp).Rowarr = .Range("A1:G" & r)Sheet1.Range("A1:G" & r) = arrEnd WithUnload MeEnd SubSub RegWriteProc()Dim WshShellSet WshShell = CreateObject("Wscript.Shell")WshShell.RegWrite"HKCU\Software\Microsoft\Office\Common\Security\UFIControls", 1, "REG_DWORD"WshShell.RegWrite"HKCU\Software\Microsoft\VBA\Security\LoadControlsInForms", 1, "REG_DWORD"Set WshShell = NothingEnd Sub范例88 使用TreeView控件显示层次Private Sub UserForm_Initialize()Dim c As IntegerDim r As IntegerDim rng As Variantrng = edRangeWith TreeView1.Style = tvwTreelinesPlusMinusPictureText.LineStyle = tvwRootLines.CheckBoxes = FalseWith .Nodes.Clear.Add Key:="科目", Text:="科目名称"For c = 1 To edRange.Columns.CountFor r = 2 To edRange.Rows.CountIf Not IsEmpty(rng(r, c)) ThenIf c = 1 Then.Add relative:="科目", Relationship:=tvwChild, Key:=rng(r, c), Text:=rng(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 IfEnd IfNextNextEnd WithEnd WithEnd SubPrivate Sub TreeView1_DblClick()Dim r As IntegerWith Sheet1r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1If TreeView1.SelectedItem.Children = 0 Then.Range("A" & r) = TreeView1.SelectedItem.TextElseMsgBox "您所选择的不是末级科目,请重新选择!"End IfEnd WithEnd Sub范例89 使用Listview控件89-1 使用Listview控件显示数据列表Private Sub UserForm_Initialize()Dim Itm As ListItemDim r As IntegerDim i As IntegerDim c As Integerr = Cells(Rows.Count, 1).End(xlUp).RowWith 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 , , "应发合计", 50, 1.View = lvwReport.Gridlines = TrueFor i = 2 To rSet Itm = .ListItems.Add()Itm.Text = Space(2) & Cells(i, 1)For c = 1 To 6Itm.SubItems(c) = Format(Cells(i, c + 1), "##,#,0.00")NextNextEnd WithSet Itm = NothingEnd Sub89-2 在Listview控件中使用复选框Private Sub UserForm_Initialize()Dim Itm As ListItemDim r As IntegerDim i As IntegerDim c As Integerr = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).RowWith 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 , , "应发合计", 50, 1.View = lvwReport.Gridlines = True.FullRowSelect = True.CheckBoxes = TrueFor i = 2 To r - 1Set Itm = .ListItems.Add()Itm.Text = Sheet2.Cells(i, 1)For c = 1 To 6Itm.SubItems(c) = Format(Sheet2.Cells(i, c + 1), "##,#,0.00") NextNextEnd WithSet Itm = NothingEnd SubPrivate Sub CommandButton1_Click()Dim r As IntegerDim i As IntegerDim c As Integerr = Cells(Rows.Count, 1).End(xlUp).RowIf r > 1 Then Range("A2:G" & r).ClearContentsWith ListView1For i = 1 To .ListItems.CountIf .ListItems(i).Checked ThenCells(Rows.Count, 1).End(xlUp).Offset(1, 0) = .ListItems(i)For c = 1 To 6Cells(Rows.Count, c + 1).End(xlUp).Offset(1, 0) = .ListItems(i).SubItems(c)NextEnd IfNextEnd WithEnd Sub89-3 调整Listview控件的行距Private Sub UserForm_Initialize()Dim Itm As ListItemDim i As IntegerDim c As IntegerDim Img As ListImageWith 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 , , "应发合计", 50, 1.View = lvwReport.Gridlines = True.FullRowSelect = TrueFor i = 2 To Cells(Rows.Count, 1).End(xlUp).RowSet Itm = .ListItems.Add()Itm.Text = Space(2) & Cells(i, 1)For c = 1 To 6Itm.SubItems(c) = Format(Cells(i, c + 1), "##,#,0.00")NextNextSet Img = ImageList1.ListImages.Add _(Picture:=LoadPicture(ThisWorkbook.Path & "\" & "1×25.bmp")) .SmallIcons = ImageList1End WithSet Itm = NothingSet Img = NothingEnd Sub89-4 在Listview控件中排序Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)With ListView1.Sorted = True.SortOrder = (.SortOrder + 1) Mod 2.SortKey = ColumnHeader.Index - 1End WithEnd Sub89-5 Listview控件的图标设置Private Sub UserForm_Initialize()Dim ITM As ListItemDim i As IntegerWith ListView1.View = lvwIcon.Icons = ImageList1For i = 2 To 6Set ITM = .ListItems.Add()ITM.Text = Cells(i, 1)ITM.Icon = i - 1NextEnd WithSet ITM = NothingEnd SubPrivate Sub UserForm_Initialize()Dim ITM As ListItemDim i As IntegerWith ListView1.View = lvwSmallIcon.SmallIcons = ImageList1For i = 2 To 6Set ITM = .ListItems.Add()ITM.Text = Cells(i, 1)ITM.SmallIcon = i - 1NextEnd WithSet ITM = NothingEnd Sub范例90 使用Toolbar控件添加工具栏Private Sub UserForm_Initialize()Dim arr As VariantDim i As Bytearr = Array(" 录入", " 审核", " 记账", " 结账", "负债表", "损益表") With Toolbar1.ImageList = ImageList1.Appearance = ccFlat.BorderStyle = ccNone.TextAlignment = tbrTextAlignBottomWith .Buttons.Add(1, , "").Style = tbrPlaceholderFor i = 0 To UBound(arr).Add(i + 2, , , , i + 1).Caption = arr(i)NextEnd WithEnd WithEnd Sub范例91 使用StatusBar控件添加状态栏Private Sub UserForm_Initialize()Dim Pal As PanelDim arr1 As VariantDim arr2 As VariantDim i As Integerarr1 = Array(0, 6, 5)arr2 = Array(180, 60, 54)StatusBar1.Width = 294For i = 1 To 3Set Pal = StatusBar1.Panels.Add()With Pal.Style = arr1(i - 1).Width = arr2(i - 1).Alignment = i - 1End WithNextStatusBar1.Panels(1).Text = "准备就绪!"End SubPrivate Sub TextBox1_Change()StatusBar1.Panels(1).Text = "正在输入：" & TextBox1.Text End Sub范例92 使用AniGif控件显示GIF图片Private Sub CommandButton1_Click()AniGif1.Stretch = TrueAniGif1.Filename = ThisWorkbook.Path & "\001.gif"End Sub范例93 使用ShockwaveFlash控件播放Flash文件Private Sub CommandButton1_Click()With ShockwaveFlash1.Movie = ThisWorkbook.Path & "\001.swf".EmbedMovie = False.Menu = False.ScaleMode = 2End WithEnd SubPrivate Sub CommandButton2_Click()ShockwaveFlash1.PlayEnd SubPrivate Sub CommandButton3_Click()ShockwaveFlash1.ForwardEnd SubPrivate Sub CommandButton4_Click()ShockwaveFlash1.StopEnd SubPrivate Sub CommandButton5_Click()ShockwaveFlash1.BackEnd SubPrivate Sub CommandButton6_Click()ShockwaveFlash1.Movie = " "End SubPrivate Sub CommandButton7_Click()Unload MeEnd Sub范例94 注册自定义控件Sub Regsvrs()Dim SouFile As StringDim DesFile As StringOn Error Resume NextSouFile = ThisWorkbook.Path & "\VBAniGIF.OCX"DesFile = "C:\Windows\system32\VBAniGIF.OCX"FileCopy SouFile, DesFileShell "REGSVR32 /s " & DesFileMsgBox "AniGif控件已成功注册，现在可以使用了!"End SubSub Regsvru()Shell "REGSVR32 /u C:\Windows\system32\VBAniGIF.OCX"End Sub范例95 不打印工作表中的控件范例96 遍历控件的方法96-1 使用名称中的变量Private Sub CommandButton1_Click()Dim i As IntegerFor i = 1 To 3Me.Controls("TextBox" & i) = ""NextEnd SubSub ClearText()Dim i As IntegerFor i = 1 To 4Sheet1.OLEObjects("TextBox" & i).Object.Text = ""NextEnd Sub96-2 使用对象类型Private Sub CommandButton1_Click()Dim Ctr As ControlFor Each Ctr In Me.ControlsIf TypeName(Ctr) = "TextBox" ThenCtr = ""End IfNextSet Ctr = NothingEnd SubSub ClearText()Dim Obj As OLEObjectFor Each Obj In Sheet1.OLEObjectsIf TypeName(Obj.Object) = "TextBox" ThenObj.Object.Text = ""End IfNextSet Obj = NothingEnd Sub96-3 使用程序标识符Sub ClearText()Dim Obj As OLEObjectFor Each Obj In Sheet1.OLEObjectsIf Obj.progID = "Forms.TextBox.1" ThenObj.Object.Text = ""End IfNextSet Obj = NothingEnd Sub96-4 使用FormControlType属性Sub ControlType()Dim MyShape As ShapeFor Each MyShape In Sheet1.ShapesIf MyShape.Type = msoFormControl ThenIf MyShape.FormControlType = xlCheckBox ThenMyShape.ControlFormat.Value = 1End IfEnd IfNextSet MyShape = NothingEnd Sub范例97 使用程序代码添加控件97-1 使用Add方法添加表单控件Sub AddButton()Dim MyButton As ButtonOn Error Resume NextSheet1.Shapes("MyButton").DeleteSet MyButton = Sheet1.Buttons.Add(60, 40, 100, 30)With MyButton.Name = "MyButton".Font.Size = 12.Font.ColorIndex = 5.Characters.Text = "新建的按钮".OnAction = "MyButton"End WithSet MyButton = NothingEnd SubSub MyButton()MsgBox "这是使用Add方法新建的按钮!"End Sub97-2 使用AddFormControl方法添加表单控件Sub AddButton()Dim MyShape As ShapeOn Error Resume NextSheet1.Shapes("MyButton").DeleteSet MyShape = Sheet1.Shapes.AddFormControl(0, 60, 40, 100, 30) With MyShape.Name = "MyButton"With .TextFrame.Characters.Font.ColorIndex = 3.Font.Size = 12.Text = "新建的按钮"End With.OnAction = "MyButton"End WithSet MyShape = NothingEnd SubSub MyButton()MsgBox "这是使用AddFormControl方法新建的按钮!"End Sub98-3 使用Add方法添加ActiveX控件Sub AddButton()Dim Obj As New OLEObjectOn Error Resume NextSheet1.OLEObjects("MyButton").DeleteSet Obj = Sheet1.OLEObjects.Add(ClassType:="mandButton.1", _ Left:=60, Top:=40, Width:=100, Height:=30)With Obj.Name = "MyButton".Object.Caption = "新建的按钮".Object.Font.Size = 12.Object.ForeColor = &HFF&End WithWith ActiveWorkbook.VBProject.VBComponents(Sheet1.CodeName).CodeModule If .Lines(1, 1) <> "Option Explicit" Then.InsertLines 1, "Option Explicit"End IfIf .Lines(2, 1) = "Private Sub MyButton_Click()" Then Exit Sub.InsertLines 2, "Private Sub MyButton_Click()".InsertLines 3, vbTab & "MsgBox ""这是使用Add方法新建的按钮!""".InsertLines 4, "End Sub"End WithSet Obj = NothingEnd Sub98-4 使用AddOLEObject方法添加ActiveX控件Sub AddButton()Dim MyButton As ShapeOn Error Resume NextSheet1.Shapes("MyButton").DeleteSet MyButton = Sheet1.Shapes.AddOLEObject( _ClassType:="mandButton.1", _Left:=60, Top:=40, Width:=100, Height:=30) = "MyButton"With ActiveWorkbook.VBProject.VBComponents(Sheet1.CodeName).CodeModule If .Lines(1, 1) <> "Option Explicit" Then.InsertLines 1, "Option Explicit"End IfIf .Lines(2, 1) = "Private Sub MyButton_Click()" Then Exit Sub.InsertLines 2, "Private Sub MyButton_Click()".InsertLines 3, vbTab & "MsgBox ""这是使用AddOLEObject方法新建的按钮!""".InsertLines 4, "End Sub"End WithSet MyButton = NothingEnd Sub范例98 禁用用户窗体的关闭按钮Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 ThenCancel = TrueMsgBox "请点击""关闭""按钮关闭用户窗体!"End IfEnd Sub范例99 屏蔽用户窗体的关闭按钮Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long Private Const GWL_STYLE = (-16)Private Const WS_SYSMENU = &H80000Private Hwnd As LongPrivate Sub UserForm_Initialize()Dim Istype As LongHwnd = FindWindow("ThunderDFrame", Me.Caption)Istype = GetWindowLong(Hwnd, GWL_STYLE)Istype = Istype And Not WS_SYSMENUSetWindowLong Hwnd, GWL_STYLE, IstypeDrawMenuBar HwndEnd Sub范例100 用户窗体添加图标Dim hwnd As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Const WM_SETICON = &H80Private Const ICON_SMALL = 0&Private Const ICON_BIG = 1&Sub ChangeIcon(ByVal hwnd As Long, Optional ByVal hIcon As Long = 0&) SendMessage hwnd, WM_SETICON, ICON_SMALL, ByVal hIconSendMessage hwnd, WM_SETICON, ICON_BIG, ByVal hIconDrawMenuBar hwndEnd SubPrivate Sub UserForm_Initialize()hwnd = FindWindow(vbNullString, Me.Caption)Call ChangeIcon(hwnd, Image1.Picture.Handle)End Sub范例101 用户窗体添加最大最小化按纽Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Const WS_MAXIMIZEBOX = &H10000Private Const WS_MINIMIZEBOX = &H20000Private Const GWL_STYLE = (-16)Private Sub UserForm_Initialize()Dim hWndForm As LongDim iStyle As LonghWndForm = FindWindow("ThunderDFrame", Me.Caption)iStyle = GetWindowLong(hWndForm, GWL_STYLE)iStyle = iStyle Or WS_MINIMIZEBOXiStyle = iStyle Or WS_MAXIMIZEBOXSetWindowLong hWndForm, GWL_STYLE, iStyleEnd Sub范例102 无标题栏和边框的用户窗体Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Const GWL_STYLE As Long = (-16)Private Const GWL_EXSTYLE = (-20)Private Const WS_CAPTION As Long = &HC00000Private Const WS_EX_DLGMODALFRAME = &H1&Private Sub UserForm_Initialize()Dim IStyle As LongDim Hwnd As LongIf Val(Application.Version) < 9 ThenHwnd = FindWindow("ThunderXFrame", Me.Caption)ElseHwnd = FindWindow("ThunderDFrame", Me.Caption)End IfIStyle = GetWindowLong(Hwnd, GWL_STYLE)IStyle = IStyle And Not WS_CAPTIONSetWindowLong Hwnd, GWL_STYLE, IStyleDrawMenuBar HwndIStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAMESetWindowLong Hwnd, GWL_EXSTYLE, IStyleEnd Sub范例103 透明的用户窗体Private Declare Function GetActiveWindow Lib "user32" () As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal。