vba - 为代码创建的控件创建鼠标事件

Question

我是 Access 的初学者，所以我需要你的帮助。我正在尝试制作“甘特图”并通过代码创建一些对象，但是当我这样做时，我无法获得事件的属性，请参阅

    Option Compare Database

    Function teste()
        MsgBox ("Foi")
    End Function

    Function gannt()
        Dim shpBox As Rectangle
        DoCmd.OpenForm "Formulário3", acDesign
        Set shpBox = Application.CreateControl("Formulário3", acRectangle, acDetail, "", "", 500, 500, 2000, 500)
        shpBox.name = "Objeto1"
        shpBox.Visible = True
        shpBox.onMouseDown = "=teste()"
        DoCmd.OpenForm "Formulário3", acNormal
    End Function

事件的过程有这样的声明：

    Private Sub Objeto1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

我认为解决方案之一是通过代码获取鼠标位置，但我没有代码来执行此操作，并且可能此代码会带来鼠标的绝对位置。

标签： vbams-access

Answer 1

经过深思熟虑，我想出了一个解决方案。

首先，我通过代码将公共函数分配给 MouseDown、MouseUp 和 MouveMove 事件来创建对象。

我已经宣布了公共变量

drag：接收到的对象 MouseDown 事件
cod_manut：对象的名称
data_manut：开始维护的日期

Option Compare Database
Option Explicit

Public drag(500) As Long
Public cod_manut(500) As Integer
Public data_manut(500, 2) As Date

Public valorX As Long '
Public valorY As Long '
Public clickX As Long '
Public clickY As Long '
Public offset As Long '

使用甘特对象填充表单的函数：

    Function gant()
        Dim shpBox As Rectangle
        Dim inicio As Integer
        Dim distancia As Integer
        Dim i As Integer
        Dim d As Date
        Dim aux As Integer
        Dim entrada As Integer
        Dim largura As Integer

        Dim tabela As Recordset
        Dim sql As String * 2048

        sql = "SELECT [Programadas + status].Código, [Programadas + status].Entrada, [Programadas + status].Saida " _
        & "FROM [Programadas + status] " _
        & "WHERE ((([Programadas + status].Entrada) < #12/31/2020#) And (([Programadas + status].Saida) >= #1/1/2020#) And (([Programadas + status].Local) = 'SOD')) " _
        & "ORDER BY [Programadas + status].Entrada, [Programadas + status].Saida;"


        Set tabela = CurrentDb.OpenRecordset(sql)

        i = 100
        While (Not tabela.EOF)
            cod_manut(i) = tabela.Fields("Código").value

            d = tabela.Fields("Entrada").value
            If (d < #1/1/2020#) Then
                d = #1/1/2020#
            End If
            data_manut(i, 0) = d

            d = tabela.Fields("Saida").value
            If (d > #12/31/2020#) Then
                d = #12/31/2020#
            End If
            data_manut(i, 1) = d

            i = i + 1
            tabela.MoveNext
        Wend

        DoCmd.OpenForm "Formulário4", acDesign
        inicio = 1350
        distancia = 408
        'Set shpBox = Forms!Formulário4!Caixa0
        For i = 100 To 173
            aux = DateDiff("d", #1/1/2020#, data_manut(i, 0))
            entrada = (aux \ 7) * 510 + (aux Mod 7) * 72
            aux = DateDiff("d", data_manut(i, 0), data_manut(i, 1))
            largura = aux * 72
            Set shpBox = Application.CreateControl("Formulário4", acRectangle, acDetail, "", "", entrada, inicio + distancia * (i - 100), largura, 300)
            shpBox.name = Replace(Str(i), " ", "")
            shpBox.BackColor = 13998939
            shpBox.BackStyle = 1
            shpBox.Visible = True
            shpBox.onMouseDown = Replace("=funcA(""" & Str(i) & """)", " ", "")
            shpBox.onMouseUp = Replace("=funcB(""" & Str(i) & """)", " ", "")
            shpBox.OnMouseMove = Replace("=funcC(""" & Str(i) & """)", " ", "")
        Next i
        DoCmd.OpenForm "Formulário4", acNormal
    End Function

函数事件

Function funcA(id As String)
    Dim b As Integer
    Dim i As Integer
    Dim nome As String

    For i = 0 To 200
        nome = (Forms!Formulário4.Controls(i).name)
        If nome = id Then
            Exit For
        End If
    Next
    b = Get_Cursor_Pos()
    clickX = ((valorX - offset) * 15) - Forms!Formulário4.Controls(i).Left
    'clickY = (valorX - offset) * 15

    drag(i) = True
End Function
Function funcB(id As String)
    Dim b As Integer
    Dim i As Integer
    Dim nome As String

    b = Get_Cursor_Pos()

    For i = 0 To 200
        nome = (Forms!Formulário4.Controls(i).name)
        If nome = id Then
            Exit For
        End If
    Next

    drag(i) = False
End Function
Function funcC(id As String)
    Dim aux As Integer
    Dim i As Integer
    Dim posX As Integer
    Dim posX2 As Integer
    Dim nome As String
    Dim inicio As Integer
    Dim fim As Integer
    Dim X As Integer
    Dim Y As Integer

    inicio = 0
    fim = 28720 - 1180

    aux = Get_Cursor_Pos()
    X = (valorX - offset) * 15
    Y = (valorX - offset) * 15
    For i = 0 To 200
        nome = (Forms!Formulário4.Controls(i).name)
        If nome = id Then
            Exit For
        End If
    Next
    aux = 0

    If drag(i) = True Then 'And Button = acLeftButton Then

        'If Shift = acShiftMask Then
            posX2 = X - clickX
            If Abs(posX2 - posX) > 72 Then
                posX = ((posX2 - posX) \ 72) * 72 + posX + 3
                posX = posX + (posX \ 504) * 6
            End If
        'Else
        '    posX = X - clickX
        'End If

        If posX < inicio Then
            posX = inicio
        ElseIf (posX + Forms!Formulário4.Controls(i).Width) > fim Then
            posX = fim - Forms!Formulário4.Controls(i).Width
        End If

        Forms!Formulário4.Controls(i).Left = posX
        Forms!Formulário4.mouse1.Caption = ((posX \ 510)) * 7 + (posX - ((posX \ 510) * 510) - 3) \ 72
        Forms!Formulário4.Mouse2.Caption = (posX \ 510) + 1
    End If
End Function

我必须使用此代码来获取绝对鼠标位置，但必须进行转换才能使用此值
注意：此值以像素为单位，我需要乘以 15 以得到缇。

' Access the GetCursorPos function in user32.dll
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

' Access the GetCursorPos function in user32.dll
Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long

' GetCursorPos requires a variable declared as a custom data type
' that will hold two integers, one for x value and one for y value
Type POINTAPI
   X_Pos As Long
   Y_Pos As Long
End Type
' Main routine to dimension variables, retrieve cursor position,
' and display coordinates
Function Get_Cursor_Pos()
    ' Dimension the variable that will hold the x and y cursor positions
    Dim Hold As POINTAPI

    ' Place the cursor positions in variable Hold
    GetCursorPos Hold

    ' Display the cursor position coordinates
    valorX = Hold.X_Pos ' \ 15 ' Transform to twips
    valorY = Hold.Y_Pos ' \ 15 ' Transform to twips

End Function

最后，我使用 MouseEvent 的默认参数创建一个对象，以 X 的增量值，并计算要使用的必要偏移量：

Private Sub calibracao_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim aux As Integer
    aux = Get_Cursor_Pos()
    offset = valorX - (X \ 15) ' To Twips

    Forms!Formulário4!mouse1.Caption = X ' Twips
    Forms!Formulário4.Mouse2.Caption = (valorX - offset) * 15 ' - offset

End Sub

这是最终结果：拖拽
manut
后的甘特图

注意：我不能使文件可用，因为有机密信息。

感谢所有阅读并可能想到解决方案的人，请原谅我的一些英语错误。