20.1 用户窗体开发特性
20.2 预览一个简单窗体
代码清单20.1: 简单的窗体,简单的代码
代码
'代码清单20.1: 简单的窗体,简单的代码
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
SaveSheetName
Unload Me
End Sub
Private Sub SaveSheetName()
On Error Resume Next
ActiveSheet.Name = txtActiveSheet.Text
End Sub
Private Sub UserForm_Initialize()
txtActiveSheet.Text = ActiveSheet.Name
'Pre-select all of the text in the text box.
txtActiveSheet.SelStart = 0
txtActiveSheet.SelLength = Len(txtActiveSheet.Text)
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
SaveSheetName
Unload Me
End Sub
Private Sub SaveSheetName()
On Error Resume Next
ActiveSheet.Name = txtActiveSheet.Text
End Sub
Private Sub UserForm_Initialize()
txtActiveSheet.Text = ActiveSheet.Name
'Pre-select all of the text in the text box.
txtActiveSheet.SelStart = 0
txtActiveSheet.SelLength = Len(txtActiveSheet.Text)
End Sub
20.3 窗体意味着需要显示
20.3.1 先显示，再提问
代码清单20.2: 使用Show方法显示窗体
代码
'代码清单20.2: 使用Show方法显示窗体
Sub SimpleFormExample()
'Show form modally
ShowSimpleForm True
MsgBox "ok - same form now, but modeless.", vbOKOnly
'Show form modeless
ShowSimpleForm False
MsgBox "Exiting the simpleFormExample procedure.", vbOKOnly
End Sub
'display the simple form
Sub ShowSimpleForm(bModal As Boolean)
If bModal Then
frmSimpleForm.Show vbModal
Else
frmSimpleForm.Show vbModeless
End If
End Sub
ShowSimpleForm False
MsgBox "Exiting the simpleFormExample procedure.", vbOKOnly
End Sub
'display the simple form
Sub ShowSimpleForm(bModal As Boolean)
If bModal Then
frmSimpleForm.Show vbModal
Else
frmSimpleForm.Show vbModeless
End If
End Sub
20.3.2 装入和现实
代码清单20.3: 在显示之前向内存装入一个窗体
代码
'代码清单20.3: 在显示之前向内存装入一个窗体
'Modify the simple form before showing it
Sub ModifySimpleForm()
Dim sNewCaption As String
'Load the form into memory
Load frmSimpleForm
'Prompt for a new caption
sNewCaption = InputBox("Enter a caption for the form.")
'Set the new caption
frmSimpleForm.Caption = sNewCaption
'Show another instance of the form
MsgBox "OK - same form again except with default caption", vbOKOnly
frmSimpleForm.Show
End Sub
'Modify the simple form before showing it
Sub ModifySimpleForm()
Dim sNewCaption As String
'Load the form into memory
Load frmSimpleForm
'Prompt for a new caption
sNewCaption = InputBox("Enter a caption for the form.")
'Set the new caption
frmSimpleForm.Caption = sNewCaption
'Show another instance of the form
MsgBox "OK - same form again except with default caption", vbOKOnly
frmSimpleForm.Show
End Sub
20.3.3 Classy窗体
代码清单20.4:Classy窗体的代码
'代码清单20.4:Classy窗体的代码
Private Sub cmdOK_Click()
Me.Hide
End Sub
Private Sub cmdOK_Click()
Me.Hide
End Sub
代码清单20.5: Classy窗体范例
代码
'代码清单20.5: Classy窗体范例
Sub ClassyFormExample()
Dim frm As frmClassy
Dim vResponse As Variant
'Instantiate frmClassy
'This has the same effect as: Load frmClassy
Set frm = New frmClassy
'Prefill the edit box with a value(just for fun)
frm.txtStuff = "Good Stuff"
frm.Show
'Form is now hidden, but you can still manipulate it
vResponse = MsgBox("the classy form text box says: " & frm.txtStuff & ". View again ?", vbYesNo)
If vResponse = vbYes Then
'The form is still alive - show it
'See - txtStuff has the same value as before
frm.Show
End If
'RIP o Classy one
Set frm = Nothing
End Sub
Sub ClassyFormExample()
Dim frm As frmClassy
Dim vResponse As Variant
'Instantiate frmClassy
'This has the same effect as: Load frmClassy
Set frm = New frmClassy
'Prefill the edit box with a value(just for fun)
frm.txtStuff = "Good Stuff"
frm.Show
'Form is now hidden, but you can still manipulate it
vResponse = MsgBox("the classy form text box says: " & frm.txtStuff & ". View again ?", vbYesNo)
If vResponse = vbYes Then
'The form is still alive - show it
'See - txtStuff has the same value as before
frm.Show
End If
'RIP o Classy one
Set frm = Nothing
End Sub
代码清单20.6: Classy窗体的多个实例
代码
'代码清单20.6: Classy窗体的多个实例
Sub ClassyFormExample2()
Dim frm1 As frmClassy
Dim frm2 As frmClassy
Set frm1 = New frmClassy
With frm1
.Caption = "I am Classy"
.Show
End With
Set frm2 = New frmClassy
With frm2
.Caption = "I am Classy too."
.txtStuff = "I am Classy said '" & frm1.txtStuff & "'"
.Show
End With
Set frm1 = Nothing
Set frm2 = Nothing
End Sub
Sub ClassyFormExample2()
Dim frm1 As frmClassy
Dim frm2 As frmClassy
Set frm1 = New frmClassy
With frm1
.Caption = "I am Classy"
.Show
End With
Set frm2 = New frmClassy
With frm2
.Caption = "I am Classy too."
.txtStuff = "I am Classy said '" & frm1.txtStuff & "'"
.Show
End With
Set frm1 = Nothing
Set frm2 = Nothing
End Sub
20.4 窗体的生命周期
代码清单20.7: 跟踪窗体事件
代码
'代码清单20.7: 跟踪窗体事件
Dim mws As Worksheet
Dim msColor As String
Private Sub chkGridlines_Click()
RecordEvent chkGridlines.Name, "Click"
ActiveWindow.DisplayGridlines = chkGridlines.Value
SetSummary
End Sub
Private Sub chkWeirdFont_Click()
'It is possible that the font "Bradley Hand ITC"
'may not be present on every PC
On Error Resume Next
RecordEvent chkWeirdFont.Name, "Click"
If chkWeirdFont.Value Then
mws.Cells.Font.Name = "Bradley Hand ITC"
Else
mws.Cells.Font.Name = "Arial"
End If
SetSummary
End Sub
Private Sub cmdHide_Click()
RecordEvent cmdHide.Name, "Click"
Me.Hide
'Pause for brief period and
'then reshow the form
Application.Wait Now + 0.00003
Me.Show
End Sub
Private Sub cmdOK_Click()
RecordEvent cmdOK.Name, "Click"
Unload Me
End Sub
Private Function RecordEvent(sControl As String, sEvent As String)
Dim rg As Range
Set rg = mws.Cells(65536, 1).End(xlUp).Offset(1, 0)
rg.Value = sControl
rg.Offset(0, 1).Value = sEvent
Set rg = Nothing
End Function
Private Sub frmOptions_Click()
RecordEvent frmOptions.Name, "Click"
End Sub
Private Sub optBlack_Change()
RecordEvent optBlack.Name, "Change"
End Sub
Private Sub optBlack_Click()
RecordEvent optBlack.Name, "Click"
msColor = "Black"
mws.Cells.Font.Color = vbBlack
SetSummary
End Sub
Private Sub optBlue_Change()
RecordEvent optBlue.Name, "Change"
End Sub
Private Sub optBlue_Click()
RecordEvent optBlue.Name, "Click"
msColor = "Blue"
mws.Cells.Font.Color = vbBlue
End Sub
Private Sub optGreen_Change()
RecordEvent OptGreen.Name, "Change"
End Sub
Private Sub optGreen_Click()
RecordEvent OptGreen.Name, "Click"
msColor = "Green"
mws.Cells.Font.Color = vbGreen
End Sub
Private Sub txtName_AfterUpdate()
RecordEvent txtName.Name, "AfterUpdate"
mws.Name = txtName.Value
SetSummary
End Sub
Private Sub txtName_Change()
On Error Resume Next
RecordEvent txtName.Name, "Change"
End Sub
Private Sub UserForm_Activate()
RecordEvent Me.Name, "Activate"
End Sub
Private Sub UserForm_Deactivate()
RecordEvent Me.Name, "Deactivate"
End Sub
Private Sub UserForm_Initialize()
On Error GoTo ErrHandler
'Refer via worksheet code name
'since this form can change the display name
Set mws = wsEventTracing
RecordEvent Me.Name, "initialize"
'Activate the worksheet so you
'can watch the events occur
mws.Activate
'Initialize controls on the form
chkGridlines.Value = ActiveWindow.DisplayGridlines
txtName.Text = mws.Name
If mws.Cells.Font.Name <> "Bradley Hand ITC" Then
chkWeirdFont.Value = False
Else
chkWeirdFont.Value = True
End If
InitializeBackgroundOptions
SetSummary
Exit Sub
ErrHandler:
Debug.Print "UserForm_Initialize: " & Err.Description
Unload Me
End Sub
Private Sub InitializeBackgroundOptions()
Select Case mws.Cells.Font.Color
Case vbBlack
optBlack.Value = True
msColor = "Black"
Case vbBlue
optBlue.Value = True
msColor = "Blue"
Case vbGreen
OptGreen.Value = True
msColor = "Green"
Case Else
mws.Cells.Interior.Color = vbBlack
optBlack.Value = True
End Select
End Sub
Private Sub SetSummary()
Dim sGridlines As String
Dim sColor As String
Dim sFont As String
If chkWeirdFont.Value Then
sFont = "weird"
Else
sFont = "Standard"
End If
lblSummary.Caption = mws.Name & " shows its data " & _
sGridlines & " using a " & sFont & ", " & _
msColor & " font "
End Sub
Dim mws As Worksheet
Dim msColor As String
Private Sub chkGridlines_Click()
RecordEvent chkGridlines.Name, "Click"
ActiveWindow.DisplayGridlines = chkGridlines.Value
SetSummary
End Sub
Private Sub chkWeirdFont_Click()
'It is possible that the font "Bradley Hand ITC"
'may not be present on every PC
On Error Resume Next
RecordEvent chkWeirdFont.Name, "Click"
If chkWeirdFont.Value Then
mws.Cells.Font.Name = "Bradley Hand ITC"
Else
mws.Cells.Font.Name = "Arial"
End If
SetSummary
End Sub
Private Sub cmdHide_Click()
RecordEvent cmdHide.Name, "Click"
Me.Hide
'Pause for brief period and
'then reshow the form
Application.Wait Now + 0.00003
Me.Show
End Sub
Private Sub cmdOK_Click()
RecordEvent cmdOK.Name, "Click"
Unload Me
End Sub
Private Function RecordEvent(sControl As String, sEvent As String)
Dim rg As Range
Set rg = mws.Cells(65536, 1).End(xlUp).Offset(1, 0)
rg.Value = sControl
rg.Offset(0, 1).Value = sEvent
Set rg = Nothing
End Function
Private Sub frmOptions_Click()
RecordEvent frmOptions.Name, "Click"
End Sub
Private Sub optBlack_Change()
RecordEvent optBlack.Name, "Change"
End Sub
Private Sub optBlack_Click()
RecordEvent optBlack.Name, "Click"
msColor = "Black"
mws.Cells.Font.Color = vbBlack
SetSummary
End Sub
Private Sub optBlue_Change()
RecordEvent optBlue.Name, "Change"
End Sub
Private Sub optBlue_Click()
RecordEvent optBlue.Name, "Click"
msColor = "Blue"
mws.Cells.Font.Color = vbBlue
End Sub
Private Sub optGreen_Change()
RecordEvent OptGreen.Name, "Change"
End Sub
Private Sub optGreen_Click()
RecordEvent OptGreen.Name, "Click"
msColor = "Green"
mws.Cells.Font.Color = vbGreen
End Sub
Private Sub txtName_AfterUpdate()
RecordEvent txtName.Name, "AfterUpdate"
mws.Name = txtName.Value
SetSummary
End Sub
Private Sub txtName_Change()
On Error Resume Next
RecordEvent txtName.Name, "Change"
End Sub
Private Sub UserForm_Activate()
RecordEvent Me.Name, "Activate"
End Sub
Private Sub UserForm_Deactivate()
RecordEvent Me.Name, "Deactivate"
End Sub
Private Sub UserForm_Initialize()
On Error GoTo ErrHandler
'Refer via worksheet code name
'since this form can change the display name
Set mws = wsEventTracing
RecordEvent Me.Name, "initialize"
'Activate the worksheet so you
'can watch the events occur
mws.Activate
'Initialize controls on the form
chkGridlines.Value = ActiveWindow.DisplayGridlines
txtName.Text = mws.Name
If mws.Cells.Font.Name <> "Bradley Hand ITC" Then
chkWeirdFont.Value = False
Else
chkWeirdFont.Value = True
End If
InitializeBackgroundOptions
SetSummary
Exit Sub
ErrHandler:
Debug.Print "UserForm_Initialize: " & Err.Description
Unload Me
End Sub
Private Sub InitializeBackgroundOptions()
Select Case mws.Cells.Font.Color
Case vbBlack
optBlack.Value = True
msColor = "Black"
Case vbBlue
optBlue.Value = True
msColor = "Blue"
Case vbGreen
OptGreen.Value = True
msColor = "Green"
Case Else
mws.Cells.Interior.Color = vbBlack
optBlack.Value = True
End Select
End Sub
Private Sub SetSummary()
Dim sGridlines As String
Dim sColor As String
Dim sFont As String
If chkWeirdFont.Value Then
sFont = "weird"
Else
sFont = "Standard"
End If
lblSummary.Caption = mws.Name & " shows its data " & _
sGridlines & " using a " & sFont & ", " & _
msColor & " font "
End Sub
20.5 用户友好设置
代码清单20.8: 管理Settings窗体
代码
'代码清单20.8: 管理Settings窗体
Dim moSetting As setting
Dim moSettings As settings
Private Sub cboSetting_Change()
'Get indicated setting and update
'controls appropriately
RefreshControls
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdEdit_Click()
Dim sPassword As String
If Not moSetting Is Nothing Then
'for setReadProtectedWrite, you need to call
'ChangeEditMode using the Password parameter
If moSetting.settingtype = setReadProtectedWrite Then
'have the user fill in their password
frmPassword.Show
sPassword = frmPassword.Password
Unload frmPassword
'make sure they entered a password
If frmPassword.Tag = CStr(vbCancel) Then Exit Sub
'try and change the edit mode
If moSetting.changeeditmode(True, sPassword) Then
txtValue.Enabled = True
Else
txtValue.Enabled = False
MsgBox "invalid password", vbOKOnly
End If
Else
'Don't need a password for unrestricted
'read/write settings.
moSetting.changeeditmode True
End If
End If
End Sub
Private Sub cmdSave_Click()
If Not moSetting Is Nothing Then
moSetting.Value = txtValue.Text
'turn off editing ablility
moSetting.changeeditmode False
cmdSave.Enabled = False
txtValue.Enabled = False
End If
End Sub
Private Sub txtValue_Change()
cmdSave.Enabled = True
End Sub
Private Sub UserForm_Initialize()
Set moSettings = New settings
cmdSave.Enabled = False
'load cbosetting with settings
LoadSettings
'default to first setting in list
If cboSetting.ListCount > 0 Then
cboSetting.ListIndex = 0
End If
End Sub
Private Sub LoadSettings()
Dim lRow As Long
Dim oSetting As setting
Dim nSettingCount As Integer
Dim nSetting As Integer
nSettingCount = moSettings.Count
'exit if there are not any settings
If nSettingCount = 0 Then Exit Sub
For nSetting = 1 To nSettingCount
'Get setting
Set oSetting = moSettings.Item(nSetting)
'add all settings except private settings
If oSetting.settingtype <> setprivate Then
cboSetting.AddItem oSetting.Name
End If
Next
Set oSetting = Nothing
End Sub
Private Sub RefreshControls()
Dim sSetting As String
Dim sValue As String
Dim sComment As String
Set moSetting = moSettings.Item(cboSetting.Value)
If Not moSetting Is Nothing Then
'disable edit ablility for read-only settings
If moSetting.settingtype = setreadonly Then
cmdEdit.Enabled = False
Else
'enable edit ablility for other settings
cmdEdit.Enabled = True
End If
txtValue.Text = moSetting.Value
txtDescription.Text = moSetting.Description
End If
txtValue.Enabled = False
cmdSave.Enabled = False
End Sub
Dim moSetting As setting
Dim moSettings As settings
Private Sub cboSetting_Change()
'Get indicated setting and update
'controls appropriately
RefreshControls
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdEdit_Click()
Dim sPassword As String
If Not moSetting Is Nothing Then
'for setReadProtectedWrite, you need to call
'ChangeEditMode using the Password parameter
If moSetting.settingtype = setReadProtectedWrite Then
'have the user fill in their password
frmPassword.Show
sPassword = frmPassword.Password
Unload frmPassword
'make sure they entered a password
If frmPassword.Tag = CStr(vbCancel) Then Exit Sub
'try and change the edit mode
If moSetting.changeeditmode(True, sPassword) Then
txtValue.Enabled = True
Else
txtValue.Enabled = False
MsgBox "invalid password", vbOKOnly
End If
Else
'Don't need a password for unrestricted
'read/write settings.
moSetting.changeeditmode True
End If
End If
End Sub
Private Sub cmdSave_Click()
If Not moSetting Is Nothing Then
moSetting.Value = txtValue.Text
'turn off editing ablility
moSetting.changeeditmode False
cmdSave.Enabled = False
txtValue.Enabled = False
End If
End Sub
Private Sub txtValue_Change()
cmdSave.Enabled = True
End Sub
Private Sub UserForm_Initialize()
Set moSettings = New settings
cmdSave.Enabled = False
'load cbosetting with settings
LoadSettings
'default to first setting in list
If cboSetting.ListCount > 0 Then
cboSetting.ListIndex = 0
End If
End Sub
Private Sub LoadSettings()
Dim lRow As Long
Dim oSetting As setting
Dim nSettingCount As Integer
Dim nSetting As Integer
nSettingCount = moSettings.Count
'exit if there are not any settings
If nSettingCount = 0 Then Exit Sub
For nSetting = 1 To nSettingCount
'Get setting
Set oSetting = moSettings.Item(nSetting)
'add all settings except private settings
If oSetting.settingtype <> setprivate Then
cboSetting.AddItem oSetting.Name
End If
Next
Set oSetting = Nothing
End Sub
Private Sub RefreshControls()
Dim sSetting As String
Dim sValue As String
Dim sComment As String
Set moSetting = moSettings.Item(cboSetting.Value)
If Not moSetting Is Nothing Then
'disable edit ablility for read-only settings
If moSetting.settingtype = setreadonly Then
cmdEdit.Enabled = False
Else
'enable edit ablility for other settings
cmdEdit.Enabled = True
End If
txtValue.Text = moSetting.Value
txtDescription.Text = moSetting.Description
End If
txtValue.Enabled = False
cmdSave.Enabled = False
End Sub
20.5.1 原始口令集
代码清单20.9: Password窗体使用的事件过程
代码
'代码清单20.9: Password窗体使用的事件过程
Dim msPassword As String
Public Property Get Password() As Variant
Password = msPassword
End Property
Private Sub cmdCancel_Click()
msPassword = CStr(vbCancel)
'tag form to indicate how the form was dispatched
Me.Tag = vbCancel
Me.Hide
End Sub
Private Sub cmdOK_Click()
msPassword = txtPassword.Text
'tag form to indicate how the form was dispatched
Me.Tag = vbOK
Me.Hide
End Sub
Private Sub UserForm_Initialize()
txtPassword.SetFocus
End Sub
Dim msPassword As String
Public Property Get Password() As Variant
Password = msPassword
End Property
Private Sub cmdCancel_Click()
msPassword = CStr(vbCancel)
'tag form to indicate how the form was dispatched
Me.Tag = vbCancel
Me.Hide
End Sub
Private Sub cmdOK_Click()
msPassword = txtPassword.Text
'tag form to indicate how the form was dispatched
Me.Tag = vbOK
Me.Hide
End Sub
Private Sub UserForm_Initialize()
txtPassword.SetFocus
End Sub
代码清单20.10: 从Password窗体中检索口令
代码
'代码清单20.10: 从Password窗体中检索口令
Sub DemonstratePassword()
'Example 1: Retrieve password by inspecting txtPassword.value
frmPassword.Show
If frmPassword.Tag <> vbCancel Then
MsgBox "you entered: " & frmPassword.txtPassword.Value, vbOKOnly
Else
MsgBox "you clicked cancel.", vbOKOnly
End If
'unload form from memory
Unload frmPassword
'Example 2: Retrieve password as a property of the form
frmPassword.Show
If frmPassword.Tag <> vbCancel Then
MsgBox "you entered: " & frmPassword.Password, vbOKOnly
Else
MsgBox "you clicked cancel.", vbOKOnly
End If
'unload form from memory
Unload frmPassword
End Sub
Sub DemonstratePassword()
'Example 1: Retrieve password by inspecting txtPassword.value
frmPassword.Show
If frmPassword.Tag <> vbCancel Then
MsgBox "you entered: " & frmPassword.txtPassword.Value, vbOKOnly
Else
MsgBox "you clicked cancel.", vbOKOnly
End If
'unload form from memory
Unload frmPassword
'Example 2: Retrieve password as a property of the form
frmPassword.Show
If frmPassword.Tag <> vbCancel Then
MsgBox "you entered: " & frmPassword.Password, vbOKOnly
Else
MsgBox "you clicked cancel.", vbOKOnly
End If
'unload form from memory
Unload frmPassword
End Sub
