Функция перетаскивания мышью Access 2016 практически завершена

Question

Я нашел работающий код VBA для поддержки перетаскивания, но я вернулся с его настройкой.

1. После того, как я активировал «перетаскивание», я могу запустить новый макрос или закрыть Если он находится в
2. Это процессор HOG, я могу наблюдать скачок загрузки моего процессора при каждом запуске.

Я хочу знать, есть ли другой способ выполнить перетаскивание Возможность и возможность использования других макросов во время работы: после запуска функции перетаскивания она переходит в oop, пока не найдет файл.

Вот код, который я использую [ Код модуля]

Option Compare Text
Option Explicit

Public CDrag As CDragDrop
Public lpPrevWndProc As Long
Public Const GWL_WNDPROC = (-4)
Public Const WM_DROPFILES = &H233
Public Const GetNumOfFiles = &HFFFF


Public Declare Function CallWindowProc Lib "user32" Alias _
                                       "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
                                          ByVal hWnd As Long, _
                                                      ByVal Msg As Long, _
                                                      ByVal wParam As Long, _
                                                      ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
                                  "SetWindowLongA" (ByVal hWnd As Long, _
                                                    ByVal nIndex As Long, _
                                                    ByVal dwNewLong As Long) As Long

Public Declare Sub DragAcceptFiles Lib "shell32.dll" _
                               (ByVal hWnd As Long, _
                                ByVal fAccept As Long)

Public Declare Sub DragFinish Lib "shell32.dll" _
                          (ByVal hDrop As Long)

Public Declare Function DragQueryFile Lib "shell32.dll" _
                                  Alias "DragQueryFileA" (ByVal hDrop As Long, _
                                                          ByVal lFile As Long, _
                                                          ByVal lpFileName As String, _
                                                          ByVal cbLen As Long) As Long

 Public Function WindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
    '
    '
    ' THIS IS WHERE IT LOOPS UNTIL IT FINDS A FILE
    '
    '
    If Msg = WM_DROPFILES Then
        'Files have been dropped
        CDrag.SubClassUnHookForm
    Else
        WindowProc = CallWindowProc(lpPrevWndProc, hWnd, Msg, wp, lp)
    End If
End Function

Вот код, который я использую [Модуль класса]

Option Compare Database
Option Explicit

Private frm As Object
Private txt As Object

Public Property Set Form(frmIn As Object)
    Set frm = frmIn
End Property

Public Property Set textbox(txtin As Object)
    Set txt = txtin
End Property

Public Sub SubClassHookForm(Form As Object)

    Call DragAcceptFiles(frm.hWnd, 1)

    lpPrevWndProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf WindowProc)

    Set CDrag = Me

End Sub

Public Sub SubClassUnHookForm()

    Call SetWindowLong(frm.hWnd, GWL_WNDPROC, lpPrevWndProc)

    Call DragAcceptFiles(frm.hWnd, 0)

End Sub


Sub AcceptDroppedFiles(hDrop As Long)

    Dim lNumOfFiles As Long

    Dim lReturn As Long

    Dim sFilename As String

    Dim lm As Long

    'Get the number of dropped files
    lNumOfFiles = DragQueryFile(hDrop, GetNumOfFiles, 0&, 0)

    For lm = 0 To lNumOfFiles
        'Allocate buffer for the name of the file

        sFilename = String$(257, Chr$(0))
        'Get the name of the file

        lReturn = DragQueryFile(hDrop, lm, sFilename, Len(sFilename))

        'Add the file name to the list

        If lReturn > 0 Then
            ImportXML sFilename
                'txt.Text = txt.Text & Left$(sFilename, lReturn) & vbCrLf
        End If

    Next lm
    'Tell Windows to free the memory allocated to store the dropped files
    DragFinish hDrop
End Sub