New Page 1
 本 书 经
典 内 容 赏 析 |
|
如何实现左右移动项目的列表框 |
如何实现通用的Office Xp按钮界面效果 |
|
如何编写传递多个参数给窗体和报表的函数 |
如何设计可定定义流程图的程序 |
|
如何读取使用插入对象插入的OLE字段的内容 |
通用的窗体页眉与页脚 |
|
书中其它经典内容 |
|
|
|
|
|
124
|
如何实现通用的Office XP按钮界面效果 |
适用版本：97、2000、2002、2003 |
| 人气 95％ |
难度系数 ***** |
|
|
问题详述 |
| 如何使用标签控件模拟Office XP的按钮的界面效果？由于在每个窗体都可能需要用到这个模块，能否编写成一个通用的模块，在窗体加载时只需简单调用一个函数就能实现Office XP的按钮的界面效果？ |
|
专家解答(详细代码请参见本书内容) |
要模拟Office XP按钮的界面效果，主要是处理鼠标的“ MouseDown”、“ MouseUp”、“MouseMove”、“ MouseDown”等事件，为每个事件编写自定义的函数，然后在窗体打开或加载的时候设置控件的鼠标事件为相应的自定义函数，MouseMove的自定义函数代码如下。
|
首先创建一个通用函数来初始化窗体上的控件，以便所有控件在发生鼠标事件时都调用上面的通用处理过程。同时，这个函数也处理其他一些通用设置，如设置页眉页脚的背景与前景颜色、自动设置子窗体的栏位属性、设置必须输入字段的控件特殊显示效果等。代码如下。
'===============================================================================>>>>>>>>
'-函数名称: glInitXpStyle
'-功能描述: 初始化窗体的XP风格
'-输入参数: 参数1:rstrFrmName String 窗体名称
'-返回参数: 无
'-使用示例: glInitXpStyle "frmMainMenu"
'-相关调用: SetMouseMove glMouseDown glMouseUp
'-使用注意: 只适用Label TextBox CommandButton ComboBox OptionButton CheckBox
'-兼 容 性: 97,2000,XP compatible
'-参考资料:
'-作 者: 王宇虹 修改：王宇虹
'-创建日期; 2002-08-26 更新日期: 2002-08-28 ,2002-11-15
'-图 解:
'===============================================================================--<>>>>>
|
Public Function glInitXpStyle(rfrmForm As Form) As Boolean
On Error Resume Next
'Dim frm As Form
Dim ctr As Control
Dim ctrLabel As Control
Dim sct As Section
Dim iBtnCnt As Integer
Dim iBtnCnt2 As Integer
Dim i As Integer
Dim obj As Section
Dim blnHaveGetColor As Boolean
Dim strFrmName As String
Dim strPFrmName As String
Dim strSubFormName As String
Dim lngLastForeColor As Long
Dim blnIsEditActiveX As Boolean
Dim blnHavLabel As Boolean
Dim blnMustInput As Boolean
Dim intPos As Integer
Dim strTemp As String
Dim intTemp As Integer
Dim varName As Variant
Dim strCboColumnWidths As String
glInitXpStyle = True
Dim rs As Recordset
Dim strCpName As String
Dim strIpAddress As String
Dim strModule As String
Dim intCnt As Integer
Dim strCompanyMi As String
Dim strModuleMi As String
strCompanyMi = Nz(CodeProject.Properties("FCompany"), "")
Application.Echo False '暂时关闭屏幕刷新
strFrmName = rfrmForm.Name
strPFrmName = rfrmForm.Parent.Name
If err.Number <> 0 Then
strPFrmName = ""
End If
rfrmForm.KeyPreview = True
'For Each sct In frm.Section '历遍被初始化窗体上的所有需XP风格的控件,设置它们的各个鼠标事件
rfrmForm.Section(acDetail).OnMouseMove = "=glMouseMove('XPsection','" & strFrmName & "','" & strPFrmName & "')"
rfrmForm.Section(acDetail).BackColor = Val(CurrentProject.Properties("FFrmDetailBackColor"))
rfrmForm.Section(acHeader).OnMouseMove = "=glMouseMove('XPsection','" & strFrmName & "','" & strPFrmName & "')"
rfrmForm.Section(acHeader).BackColor = Val(CurrentProject.Properties("FFrmHeaderBackColor"))
rfrmForm.Section(acFooter).OnMouseMove = "=glMouseMove('XPsection','" & strFrmName & "','" & strPFrmName & "')"
rfrmForm.Section(acFooter).BackColor = Val(CurrentProject.Properties("FFrmFooterBackColor"))
'Next
rfrmForm.OnUnload = "=glUnloadForm('" & strFrmName & "','" & strPFrmName & "')"
For Each ctr In rfrmForm.Controls '历遍被初始化窗体上的所有需XP风格的控件,设置它们的各个鼠标事件
If TypeOf ctr Is OptionGroup Then
ctr.Controls(0).BackColor = rfrmForm.Section(ctr.Section).BackColor
End If
'-------------------------设置子窗体栏位属性---------------------
If (TypeOf ctr Is SubForm) And ctr.Section = acDetail Then
Dim strTag As String
Dim sfmCtr As Control
Dim frmSubForm As Control
'Dim strSubFormName As String
Dim strCtrCaption As String
Set frmSubForm = ctr
strSubFormName = ctr.Form.Name
Dim rst As New ADODB.Recordset
rst.Open "select * from tblPubColumnProperty where FFormName='" & strFrmName & "' order by FSeqNo", CodeProject.Connection, adOpenStatic, adLockReadOnly
If rst.RecordCount > 0 Then
If Nz(rst("FSort")) <> "" Then
frmSubForm.Form.OrderBy = Nz(rst("FSort"))
frmSubForm.Form.OrderByOn = True
End If
For i = 0 To rst.RecordCount - 1
Set sfmCtr = frmSubForm.Form.Controls(rst("FControlName"))
sfmCtr.ColumnHidden = Not rst("FIsSelect")
sfmCtr.ColumnWidth = rst("FColumnWidth")
sfmCtr.ColumnOrder = rst("FSeqNo")
rst.MoveNext
Next
End If
Set rst = Nothing
Set ctr = Nothing
Set frmSubForm = Nothing
End If
If Left(ctr.Tag, 2) = "XP" Then
If Not (TypeOf ctr Is CustomControl) Then
ctr.OnMouseMove = "=glMouseMove('" & ctr.Name & "','" & strFrmName & "','" & strPFrmName & "')"
If InStr(ctr.Tag, "move") = 0 Then
ctr.OnMouseDown = "=glMouseDown('" & ctr.Name & "','" & strFrmName & "','" & strPFrmName & "')"
ctr.OnMouseUp = "=glMouseUp('" & ctr.Name & "','" & strFrmName & "','" & strPFrmName & "')"
End If
If blnHaveGetColor = False And ctr.ForeColor <> RGB(192, 192, 192) Then
lngLastForeColor = ctr.ForeColor
blnHaveGetColor = True
End If
If ctr.Tag = "XPdisable" Then
ctr.ForeColor = RGB(192, 192, 192)
ctr.OnClick = ""
Else
If ctr.ForeColor <> RGB(192, 192, 192) Then
Else
ctr.ForeColor = lngLastForeColor
ctr.OnClick = "[Event Procedure]"
ctr.Tag = "XP"
End If
End If
End If
With ctr
.Object.BackColor = rfrmForm.Section(ctr.Section).BackColor
'Dim aa As ctButton
.FontOver.Bold = False
.BorderType = None
.BorderOver = BorderRegular
.Object.backcolorover = Val(CurrentProject.Properties("FBtnMouseMoveBackColor"))
.Object.BorderColor = Val(CurrentProject.Properties("FBtnMouseMoveBorderColor"))
' .Object.DrawFocus = CurrentProject.Properties("FBtnShowFocus")
End With
End If
‘如果需要调用日期窗体
If InStr(ctr.Tag, "date") > 0 Then
ctr.OnDblClick = "=glOpenDockForm('XPdate')"
'ctr.OnEnter = "=glOpenDockForm('XPdate')"
ctr.OnExit = "=glCloseDockForm('XPdate')"
End If
‘如果是需要自动下拉的组合框
If InStr(ctr.Tag, "autocbo") > 0 And (TypeOf ctr Is ComboBox) Then
intPos = InStr(ctr.Tag, "autocbo")
strTemp = Mid(ctr.Tag, intPos + 7, 2)
intPos = Val(Left(strTemp, 1))
intTemp = Val(Right(strTemp, 1))
varName = Split(ctr.ColumnWidths, ";")
strTemp = ""
For i = 0 To UBound(varName)
If i = intPos - 1 Then
strTemp = strTemp & ";0"
Else
strTemp = strTemp & ";" & varName(i)
End If
Next
If Len(strTemp) > 0 Then strTemp = Mid(strTemp, 2)
ctr.OnExit = "=glSetComboColumnWidth('" & ctr.Name & "','" & strFrmName & "','" & strTemp & "')"
ctr.OnEnter = "=glSetComboColumnWidth('" & ctr.Name & "','" & strFrmName & "','" & ctr.ColumnWidths & "')"
ctr.ColumnWidths = strTemp
End If
'如果是需要自动弹出计算器的控件
If InStr(ctr.Tag, "calc") > 0 Then
ctr.OnEnter = "=glOpenDockForm('XPcalc')"
ctr.OnExit = "=glCloseDockForm('XPcalc')"
End If
If CurrentProject.Properties("FAutoDropDown") <> 0 Then
If CurrentProject.Properties("FAutoDropDown") = 1 Then
End If
End If
‘处理必须输入字段的特殊效果
If (TypeOf ctr Is TextBox) Or (TypeOf ctr Is ComboBox) Or (TypeOf ctr Is CheckBox) Or (TypeOf ctr Is OptionButton) Or (TypeOf ctr Is ListBox) Then 'Or blnIsEditActiveX
blnMustInput = False
If InStr(ctr.Tag, "NotNull") > 0 Then
blnMustInput = True
End If
If blnMustInput = False Then '不是必录入控件
If CurrentProject.Properties("FInputControlBackStyle") <> -1 Then
ctr.BackStyle = CurrentProject.Properties("FInputControlBackStyle")
End If
If CurrentProject.Properties("FInputControlBackColor") <> -1 Then
ctr.BackColor = CurrentProject.Properties("FInputControlBackColor")
End If
If CurrentProject.Properties("FInputControlForeColor") <> -1 Then
ctr.ForeColor = CurrentProject.Properties("FInputControlForeColor")
End If
此处代码太长，详见书中内容
..........
...........
............
..............
If CurrentProject.Properties("FInputLabelFontUnderline") <> 0 Then
ctrLabel.FontUnderline = CurrentProject.Properties("FInputLabelFontUnderline")
End If
If CurrentProject.Properties("FInputLabelSpecialEffect") <> -1 Then
ctrLabel.SpecialEffect = CurrentProject.Properties("FInputLabelSpecialEffect")
End If
End If
End If
Else '是必录入控件
If CurrentProject.Properties("FMustInputControlDispMode") <> 0 Then
blnHavLabel = False
If ctr.Controls.Count > 0 Then
If TypeOf ctr.Controls(0) Is Label Then
Set ctrLabel = ctr.Controls(0)
blnHavLabel = True
End If
End If
Select Case CurrentProject.Properties("FMustInputControlDispMode")
Case 1
If blnHavLabel = True Then
If Left(ctrLabel.Caption, 1) = "*" Then ctrLabel.Caption = Mid(ctrLabel.Caption, 2)
ctrLabel.Caption = "*" & Nz(ctrLabel.Caption)
End If
Case 2
If blnHavLabel = True Then
If CurrentProject.Properties("FMustInputLabelBackStyle") <> -1 Then
ctrLabel.BackStyle = CurrentProject.Properties("FMustInputLabelBackStyle")
End If
If CurrentProject.Properties("FMustInputLabelBackColor") <> -1 Then
ctrLabel.BackColor = CurrentProject.Properties("FMustInputLabelBackColor")
End If
此处代码太长，详见书中内容
..........
...........
............
..............
If CurrentProject.Properties("FMustInputLabelFontUnderline") <> 0 Then
ctrLabel.FontUnderline = CurrentProject.Properties("FMustInputLabelFontUnderline")
End If
End If
Case 3
If blnHavLabel = True Then
If CurrentProject.Properties("FMustInputLabelBackStyle") <> -1 Then
ctrLabel.BackStyle = CurrentProject.Properties("FMustInputLabelBackStyle")
End If
此处代码太长，详见书中内容
..........
...........
............
..............
Case 4
If CurrentProject.Properties("FMustInputControlBackStyle") <> -1 Then
ctr.BackStyle = CurrentProject.Properties("FMustInputControlBackStyle")
End If
此处代码太长，详见书中内容
..........
...........
............
..............
If CurrentProject.Properties("FMustInputControlFontUnderline") <> 0 Then
ctr.FontUnderline = CurrentProject.Properties("FMustInputControlFontUnderline")
End If
End Select
End If
End If
End If
Next
err = 0
strSubFormName = rfrmForm.frmPubFrmHeader.Form.Name
If err.Number = 0 Then
rfrmForm.frmPubFrmHeader.Form.lblTitle1.Caption = rfrmForm.Caption '设置页眉标题为主窗体的标题（在共用子窗体里的标签）
'设置页眉标题的前景颜色（在共用子窗体里的标签）
rfrmForm.frmPubFrmHeader.Form.lblTitle1.ForeColor = Val(CurrentProject.Properties("FFrmHeaderTitleForeColor"))
rfrmForm.frmPubFrmHeader.Form.lblTitle2.Caption = rfrmForm.Caption '设置页眉标题阴影为主窗体的标题（在共用子窗体里的标签）
'设置页眉标题的阴影颜色（在共用子窗体里的标签）
rfrmForm.frmPubFrmHeader.Form.lblTitle2.ForeColor = Val(CurrentProject.Properties("FFrmHeaderTitleBackColor"))
'设置页眉背景颜色（实际上是共用子窗体里的主体背景）
rfrmForm.frmPubFrmHeader.Form.Section(acDetail).BackColor = Val(CurrentProject.Properties("FFrmHeaderBackColor"))
'设置页脚提示文字为主窗体的标记属性值
rfrmForm.frmPubFrmFooter.Form.lblTips.Caption = rfrmForm.Tag
'设置页脚背景颜色（实际上是共用子窗体里的主体背景）
rfrmForm.frmPubFrmFooter.Form.Section(acDetail).BackColor = Val(CurrentProject.Properties("FFrmFooterBackColor"))
'设置主窗体页眉页脚的高度为各自嵌入的子窗体控件的高度
rfrmForm.Section(acHeader).Height = rfrmForm.frmPubFrmHeader.Height
rfrmForm.Section(acFooter).Height = rfrmForm.frmPubFrmFooter.Height
End If
Application.Echo True '打开屏幕刷新，以显示发生变化的窗体画面
DoCmd.Hourglass False
End Function
|
'===============================================================================
'-函数名称: glMouseMove
'-功能描述: 设置XP风格的通用鼠标移动事件
'-输入参数说明: 参数1:rstrCtrName String 控件名称
' 参数2:rstrFrmName String 窗体名称
'-返回参数说明: 无
'-使用语法示例: glMouseMove "cmdSave","frmMainMenu"
'-参考:
'-使用注意: 只适用Label TextBox CommandButton ComboBox OptionButton CheckBox
'-兼容性: 97,2000,XP compatible
'-作者: 王宇虹，改进：王宇虹
'-更新日期： 2002-08-26 ,2003-09-15
'=============================================================================== |
Public Function glMouseMove(rstrCtrName As String, rstrFrmName As String, rstrPFrmName As String)
'On Error Resume Next
Static ctrLast As Control
Static lngLastBorderColor As Long
Static lngLastForeColor As Long
Static intLastSpecialEffect As Integer
Dim strCtrNameLast As String '变量 用来保存最近一次移动过的控件名称
Dim ctr As Control '临时变量 用来定义当前控件和最近一次移动过的控件
Dim frm As Form '临时变量 用来定义当前的窗体
On Error Resume Next
If rstrPFrmName = "" Then
Set frm = Forms(rstrFrmName)
Else
Set frm = Forms(rstrPFrmName).Controls(rstrFrmName).Form
If err <> 0 Then
Set frm = Forms(rstrPFrmName).Controls("sfmSubForm").Form
End If
End If
If rstrCtrName = "XPsection" Then
'设置最后一次的控件的背景透明及字体变细
With ctrLast
' .BorderColor = 9868950
.BorderColor = lngLastBorderColor
If (TypeOf ctrLast Is Label) And (Val(CurrentProject.Properties("FBtnUseSpecialEffect")) <> 0) Then
.SpecialEffect = intLastSpecialEffect
End If
'Val (CurrentProject.Properties("FBtnMouseMoveBorderColor"))
If Left(.Tag, 5) <> "XPbar" Then
.BackStyle = 0
Else
.BackColor = 12632256
End If
'鼠标移出时是否要改变原来控件字体颜色为黑色
'.ForeColor = vbBlack
.FontBold = 0
' .FontSize = 9
If Left(.Tag, 6) = "XPmenu" Then '如果是菜单和工具栏,鼠标离开后不显示边框
.BorderStyle = 0
End If
End With
Set ctrLast = Nothing
Exit Function
End If
Set ctr = frm.Controls(rstrCtrName)
If ctr.Tag = "XPdisable" Then
ctr.ForeColor = RGB(192, 192, 192)
ctr.OnClick = ""
ctr.BorderStyle = 0
ctr.BackStyle = 0
Exit Function
End If
If (TypeOf ctr Is OptionButton) Or (TypeOf ctr Is CheckBox) Then
If ctr.Controls.Count > 0 Then
rstrCtrName = ctr.Controls(0).Name
Set ctr = ctr.Controls(0)
End If
End If
strCtrNameLast = Nz(ctrLast.Name)
If Nz(strCtrNameLast) <> "" Then
' Set ctrLast = frm.Controls(strCtrNameLast)
End If
If Left(ctr.Tag, 2) = "XP" Then '只对标记为XP的按钮起作用
If rstrCtrName <> Nz(strCtrNameLast) Then '如果鼠标还在同一个按钮上, 则跳过程序
If (ctrLast Is Nothing) Then
If ctrLast.FontBold = 1 And Left(ctrLast.Tag, 6) <> "XPhide" Then '设置最后一次的控件的背景透明及字体变细
With ctrLast
'.BorderColor = 9868950
.BorderColor = lngLastBorderColor
If (TypeOf ctrLast Is Label) And (Val(CurrentProject.Properties("FBtnUseSpecialEffect")) <> 0) Then
.SpecialEffect = intLastSpecialEffect
End If
If Left(.Tag, 5) <> "XPbar" Then
.BackStyle = 0
Else
.BackColor = 12632256
End If
'鼠标移出时是否要改变原来控件字体颜色为黑色
'.ForeColor = vbBlack
.FontBold = 0
If Left(.Tag, 6) = "XPmenu" Then '如果是菜单和工具栏,鼠标离开后不显示边框
.BorderStyle = 0
End If
End With
End If
End If
If ctr.FontBold <> 1 And Left(ctr.Tag, 6) <> "XPhide" Then '设置鼠标当前所在的控件的背景颜色及字体变粗
With ctr
If ctr.ForeColor = RGB(192, 192, 192) Then
ctr.ForeColor = lngLastForeColor
ctr.OnClick = "[Event Procedure]"
End If
此处代码太长，详见书中内容
..........
...........
............
..............
If Left(.Tag, 5) <> "XPbar" Then
.BackStyle = 1
End If
.BackColor = Val(CurrentProject.Properties("FBtnMouseMoveBackColor"))
.BorderColor = Val(CurrentProject.Properties("FBtnMouseMoveBorderColor"))
If (TypeOf ctr Is Label) And (Val(CurrentProject.Properties("FBtnUseSpecialEffect")) <> 0) Then
.SpecialEffect = Val(CurrentProject.Properties("FBtnMouseMoveSpecialEffect"))
End If
'鼠标移上时是否要改变字体颜色为黑色
'.ForeColor = vbBlack
.FontBold = 1
If Left(.Tag, 6) = "XPmenu" Then '如果是菜单和工具栏,鼠标在其上显示边框
.BorderStyle = 1
End If
End With
End If
Set ctrLast = ctr
End If
End If
End Function
|
再创建MouseDown自定义函数，处理各控件鼠标按下的事件，如果不需要鼠标按下事件的效果，也可省略这个函数，代码如下。
'===============================================================================
'-函数名称: glMouseDown
'-功能描述: 设置XP风格的通用鼠标按下事件
'-输入参数说明: 参数1:rstrCtrName String 控件名称
' 参数2:rstrFrmName String 窗体名称
'-返回参数说明: 无
'-使用语法示例: SetMouseMoveDown "cmdSave","frmMainMenu"
'-参考:
'-使用注意: 只适用Label TextBox CommandButton ComboBox OptionButton CheckBox
'-兼容性: 97,2000,XP compatible
'-作者: 王宇虹，改进：王宇虹
'-更新日期： 2002-08-26 ,2002-11-15
'=============================================================================== |
Public Function glMouseDown(rstrCtrName As String, rstrFrmName As String, rstrPFrmName As String)
On Error Resume Next
Dim ctr As Control
If rstrPFrmName = "" Then
Set ctr = Forms(rstrFrmName).Controls(rstrCtrName)
Else
Set ctr = Forms(rstrPFrmName).Controls(rstrFrmName).Form.Controls(rstrCtrName)
End If
If ctr.Tag = "XPdisable" Then Exit Function
If TypeOf Forms(rstrFrmName).ActiveControl Is TextBox Then
If Forms(rstrFrmName).RecordSource <> "" Then
If Forms(rstrFrmName).Dirty = True Then
Forms(rstrFrmName).ActiveControl.Text = Forms(rstrFrmName).ActiveControl.Text
End If
Else
Forms(rstrFrmName).ActiveControl.Text = Forms(rstrFrmName).ActiveControl.Text
End If
End If
If (TypeOf ctr Is OptionButton) Or (TypeOf ctr Is CheckBox) Then
If ctr.Controls.Count > 0 Then
rstrCtrName = ctr.Controls(0).Name
Set ctr = ctr.Controls(0)
End If
End If
With ctr
If TypeOf ctr Is Label Then
.BackColor = Val(CurrentProject.Properties("FBtnMouseDownBackColor"))
If (Val(CurrentProject.Properties("FBtnUseSpecialEffect")) <> 0) Then
.SpecialEffect = Val(CurrentProject.Properties("FBtnMouseDownSpecialEffect"))
End If
' .BackColor = 8208461
' .ForeColor = vbWhite
End If
End With
End Function
Public Function glUnloadForm(rstrFrmName As String, rstrPFrmName As String)
Dim rs As Recordset
Dim strCpName As String
Dim strIpAddress As String
End Function
Public Function SetClick()
SendKeys "{TAB}"
End Function |
再创建MouseUp自定义函数，处理各控件鼠标弹起的事件，代码如下。
'===============================================================================
'-函数名称: glMouseUp
'-功能描述: 设置XP风格的通用鼠标按下事件
'-输入参数说明: 参数1:rstrCtrName String 控件名称
' 参数2:rstrFrmName String 窗体名称
'-返回参数说明: 无
'-使用语法示例: SetMouseMoveUp "cmdSave","frmMainMenu"
'-参考:
'-使用注意: 只适用Label TextBox CommandButton ComboBox OptionButton CheckBox
'-兼容性: 97,2000,XP compatible
'-作者: 王宇虹，改进：王宇虹
'-更新日期： 2002-08-26
'=============================================================================== |
Public Function glMouseUp(rstrCtrName As String, rstrFrmName As String, rstrPFrmName As String)
Dim ctr As Control
On Error Resume Next
If rstrPFrmName = "" Then
Set ctr = Forms(rstrFrmName).Controls(rstrCtrName)
Else
Set ctr = Forms(rstrPFrmName).Controls(rstrFrmName).Form.Controls(rstrCtrName)
End If
If TypeOf ctr Is ctButton Then
ctr.ReDraw
End If
Exit Function
If ctr.Tag = "XPdisable" Then Exit Function
If (TypeOf ctr Is OptionButton) Or (TypeOf ctr Is CheckBox) Then
If ctr.Controls.Count > 0 Then
rstrCtrName = ctr.Controls(0).Name
Set ctr = ctr.Controls(0)
End If
End If
With ctr
If (TypeOf ctr Is Label) Then
.BackColor = Val(CurrentProject.Properties("FBtnMouseMoveBackColor"))
.BorderColor = Val(CurrentProject.Properties("FBtnMouseMoveBorderColor"))
If (Val(CurrentProject.Properties("FBtnUseSpecialEffect")) <> 0) Then
.SpecialEffect = Val(CurrentProject.Properties("FBtnMouseMoveSpecialEffect"))
End If
End If
End With
End Function
|
|
|
|
|
|
网友评论：（只显示最新10条。评论内容只代表网友观点，与本站立场无关！）