[求助]写一段鼠标移动事件的模块代码(火急)

fannky

BBS上找了半天还没有看到类似的模块，难道没人会写？

Public Sub Lab_on(frm As Form)
Dim Ctr As Control
For Each Ctr In frm.Controls
If (Ctr.Tag <> "no") And (TypeOf Ctr Is Label) Then

想在这里加入鼠标事件：当鼠标指在Lable时改变它的边框、背景、文字颜色等，同时复原其他Lable的默认属性
End If
Next Ctr

End Sub

hi-wzj

代码需要在lable的鼠标移动事件中书写.

fannky

以下是引用hi-wzj在2006-6-29 13:29:00的发言：


代码需要在lable的鼠标移动事件中书写.

不会吧？！n个Lable拿不是需要一一的写重复的代码？这样多麻烦啊，模块中难道就不能调用On MouseOver等响应么？如果可以有没有这方面的资料，谢谢？

hi-wzj

您可将您要执行的代码写成一个公用的过程或全局的过程。比如

sub aa（）

.......

end sub

在各标签的鼠标移动事件中： call aa

fannky

我倒是找到这样一段模块，就是不知道怎样响应的事件，云里雾里

wu8313

我从自己的库中剥离一段给你，可以实现这样的效果。

Option Compare Database

Private Sub frm_child_iamge_properties(ByVal imagename As String)

Dim CtlA As Access.Control
'循环处理活动窗体的所有控件
For Each CtlA In Me.Controls
     If CtlA.ControlType = acImage Then  '针对 图像 控件进行遍历设置
        If CtlA.name = imagename Then
          With CtlA
           ' .borderwith = 3
            .BorderColor = 16744448
            .BorderStyle = 1
            
          End With
         
        Else
        
        With CtlA
           ' .borderwith = 1
            .BorderColor = 0
            .BorderStyle = 0
        End With
         
        End If
     End If
Next CtlA

End Sub

Private Sub 图像12_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Call frm_child_iamge_properties(Me.图像12.name)

End Sub

Private Sub 图像13_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Call frm_child_iamge_properties(Me.图像13.name)

End Sub

[此贴子已经被作者于2006-6-29 18:11:35编辑过]

fannky

谢谢你的热心回复，那就合你交换一段代码吧，这是一段模块代码，在加载的时候调用gt_FormInit就可以了

Public Sub gt_FormInit(rfrmForm As Form)
On Error Resume Next
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

Application.Echo False  '暂时关闭屏幕刷新
strFrmName = rfrmForm.Name
strPFrmName = rfrmForm.Parent.Name
If Err.Number <> 0 Then
    strPFrmName = ""
End If
rfrmForm.Section(acDetail).OnMouseMove = "=gt_MouseMove('XPsection','" & strFrmName & "','" & strPFrmName & "')"
rfrmForm.Section(acDetail).BackColor = 16643312
rfrmForm.Section(acHeader).OnMouseMove = "=gt_MouseMove('XPsection','" & strFrmName & "','" & strPFrmName & "')"
rfrmForm.Section(acHeader).BackColor = 8421440
rfrmForm.Section(acFooter).OnMouseMove = "=gt_MouseMove('XPsection','" & strFrmName & "','" & strPFrmName & "')"
rfrmForm.Section(acFooter).BackColor = 14408667


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 Left(Ctr.Tag, 2) = "XP" Then
      If Not (TypeOf Ctr Is CustomControl) Then
       Ctr.OnMouseMove = "=gt_MouseMove('" & Ctr.Name & "','" & strFrmName & "','" & strPFrmName & "')"
       If InStr(Ctr.Tag, "move") = 0 Then
        Ctr.OnMouseDown = "=gt_MouseDown('" & Ctr.Name & "','" & strFrmName & "','" & strPFrmName & "')"
        Ctr.OnMouseUp = "=gt_MouseUp('" & Ctr.Name & "','" & strFrmName & "','" & strPFrmName & "')"
       End If
        If blnHaveGetColor = False And Ctr.ForeColor <> RGB(192, 192, 192) Then
            lngLastForeColor = Ctr.ForeColor
            blnHaveGetColor = True
        End If
      End If
      With Ctr
            If InStr(Ctr.Tag, "XPmenu") > 0 Then
              .Object.BorderColor = 8388608
              .Object.BackColor = rfrmForm.Section(Ctr.Section).BackColor
            Else
              If InStr(Ctr.Tag, "XPTransprant") > 0 Then
                .Object.BackColor = rfrmForm.Section(Ctr.Section).BackColor
              End If
            End If
            .Object.backcolorover = 13679776
       End With
    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 = 4194368 ' 16777215
     
     rfrmForm.frmPubFrmHeader.Form.lblTitle2.Caption = rfrmForm.Caption     '设置页眉标题阴影为主窗体的标题（在共用子窗体里的标签）
     '设置页眉标题的阴影颜色（在共用子窗体里的标签）
     rfrmForm.frmPubFrmHeader.Form.lblTitle2.ForeColor = 16777215  ' 8388608
     
     '设置页眉背景颜色（实际上是共用子窗体里的主体背景）
     rfrmForm.frmPubFrmHeader.Form.Section(acDetail).BackColor = 14671839 ' 15658734 ' 8421440
     '设置页脚提示文字为主窗体的标记属性值
     rfrmForm.frmPubFrmFooter.Form.lblTips.Caption = rfrmForm.Tag
     '设置页脚背景颜色（实际上是共用子窗体里的主体背景）
     rfrmForm.frmPubFrmFooter.Form.Section(acDetail).BackColor = 14408667 ' 15663103 ' 13697023
     '设置主窗体页眉页脚的高度为各自嵌入

kennylee

Option Compare Database
Option Explicit
Dim Ak As String
Public Function smup(TempName As String, strForm As String) '当鼠标接触标签时 , 标签显示的效果,
On Error GoTo Err_A
        Ak = TempName
        If Forms(strForm).Controls(TempName).ForeColor <> 16711935 Then '字不等于红色
        With Forms(strForm).Controls(TempName)
            .ForeColor = 16711935 '字等于红色
            .BackStyle = 1
            .BackColor = 16777215
            .HyperlinkAddress = " " '鼠标变手形
            .ControlTipText = Ak
        End With
      End If
Exit_A:
    Exit Function
Err_A:
   If Err.Number <> 0 Then
   MsgBox "鼠标接触标签时,无反应!" & Chr(10) & "错误号:" & Err.Number, vbCritical
   End If
    Resume Exit_A
End Function
Public Function smon(strForm As String) '当鼠标离开标签时,标签显示的效果
On Error GoTo Err_A
Dim TempName As String
If Ak <> "" Then
             TempName = Ak
            If Forms(strForm).Controls(TempName).ForeColor = 16711935 Then
                With Forms(strForm).Controls(TempName)
                    .ForeColor = 16777215
                    .BackStyle = 0
                    .Tag = ""
                End With
            End If
End If
Ak = ""
Exit_A:
    Exit Function
Err_A:
   If Err.Number <> 0 Then
   MsgBox "鼠标离开标签时,无反应!" & Chr(10) & "错误号:" & Err.Number, vbCritical
   End If
    Resume Exit_A
End Function

yangzikang

http://www.ccdww.com/dispbbs.asp?boardid=28&Id=23

yangzikang

这个例子不错