大礼相送，源码共享：XP网络 的通用鼠标移动函数

admin

清明到了
也许一个人的世界会很孤寂，但是请相信每当夜深人静的时候，耳畔总会想起那句“没有我的岁月里，你要保重你自己”，清明节到了，请珍重身体!


大礼相送，源码共享：XP网络 的通用鼠标移动函数
'===============================================================================
'-函数名称:         gt_MouseMove
'-功能描述:         设置XP风格的通用鼠标移动事件
'-输入参数说明:     参数1:rstrCtrName String 控件名称
'                   参数2:rstrFrmName String 窗体名称
'-返回参数说明:     无
'-使用语法示例:     gt_MouseMove "cmdSave","frmMainMenu"
'-参考:
'-使用注意:         只适用Label TextBox CommandButton ComboBox OptionButton CheckBox
'-兼容性:           97,2000,XP compatible
'-作者:             王宇虹，改进：王宇虹
'-更新日期：        2012-04-01
'===============================================================================

Public Function gt_MouseMove(rstrCtrName As String, rstrFrmName As String, rstrPFrmName As String)
On Error Resume Next
'  Exit Function  '此鼠标移动事件会导致前面死机，非法退出，注意查看原因 现暂时屏蔽
    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                                     '临时变量 用来定义当前的窗体
    Dim ctrVisible As Control
    On Error Resume Next
    'Debug.Print "ctrlast" & ctrLast.Name
    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
        '设置最后一次的控件的背景透明及字体变细
        If (TypeOf ctrLast Is CommandButton) Then
            If ctrLast.Controls.Count > 0 Then

                Set ctrVisible = ctrLast.Controls(0)
            Else
                Set ctrVisible = ctrLast
            End If
        Else
            Set ctrVisible = ctrLast
        End If

        With ctrVisible
            ' .BorderColor = 9868950
            ' Debug.Print ctrVisible.Name
            .BorderColor = lngLastBorderColor
            If (TypeOf ctrVisible 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
                ' MsgBox "dd"
            Else
                If (ctrLast.FontBold = 1 Or ctrVisible.FontBold = 1) And left(ctrLast.Tag, 6) <> "XPhide" Then  '设置最后一次的控件的背景透明及字体变细
                    If (TypeOf ctrLast Is CommandButton) Then
                        If ctrLast.Controls.Count > 0 Then

                            Set ctrVisible = ctrLast.Controls(0)
                        Else
                            Set ctrVisible = ctrLast
                        End If
                    Else
                        Set ctrVisible = ctrLast
                    End If
                    With ctrVisible
                        '.BorderColor = 9868950
                        .BorderColor = lngLastBorderColor
                        If (TypeOf ctrVisible 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
                        '  .FontSize = 9
                        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   '设置鼠标当前所在的控件的背景颜色及字体变粗
                If (TypeOf ctr Is CommandButton) Then
                    If ctr.Controls.Count > 0 Then

                        Set ctrVisible = ctr.Controls(0)
                    Else
                        Set ctrVisible = ctr
                    End If
                Else
                    Set ctrVisible = ctr
                End If
                With ctrVisible
                    If .ForeColor = RGB(192, 192, 192) Then
                        .ForeColor = lngLastForeColor
                        .OnClick = "[Event Procedure]"
                    End If
                    lngLastBorderColor = .BorderColor
                    intLastSpecialEffect = .SpecialEffect
                    lngLastForeColor = .ForeColor
                    '                If TypeOf ctr Is Label Then
                    '                    Debug.Print lngLastBorderColor
                    '                End If
                    If left(.Tag, 5) <> "XPbar" Then
                        .BackStyle = 1
                    End If
                    '.BackColor = 15584719
                    .BackColor = Val(CurrentProject.Properties("FBtnMouseMoveBackColor"))
                    ' .BorderColor = 8388608
                    .BorderColor = Val(CurrentProject.Properties("FBtnMouseMoveBorderColor"))
                    If (TypeOf ctrVisible Is Label) And (Val(CurrentProject.Properties("FBtnUseSpecialEffect")) <> 0) Then
                        .SpecialEffect = Val(CurrentProject.Properties("FBtnMouseMoveSpecialEffect"))
                    End If
                    '鼠标移上时是否要改变字体颜色为黑色
                    '.ForeColor = vbBlack
                    .FontBold = 1
                    ' .FontSize = 9
                    If left(.Tag, 6) = "XPmenu" Then  '如果是菜单和工具栏,鼠标在其上显示边框
                        .BorderStyle = 1
                    End If
                End With
            End If

            Set ctrLast = ctr

        End If
    End If
End Function

瘦子小伟

假日快乐！注意防火哟！

fnsmydyang

祝大家清明节愉快.{:soso_e100:}