Форма капли при щелчке мыши

Question

Я работал над некоторым кодом для игры в PowerPoint (с благодарностью YouTube YouTube Malik Stalbert). Я могу забрать предметы во время презентации, но не могу бросить их снова, пока не истечет время. Я хочу иметь возможность щелкнуть один раз, чтобы забрать, и снова щелкнуть, чтобы уронить.

По сути, я выбираю фигуру, перетаскиваю ее и опускаю в другую фигуру. Затем Vba проверяет, каковы координаты вновь отброшенной фигуры, если она совпадает с оператором IF внизу, то это успех (просто использование msgBox для проверки работоспособности). Работает в настоящее время, но только сбросит форму, когда таймер закончится.

Вот код:

Любая помощь приветствуется.

  Option Explicit

Private Const SM_SCREENX = 1
Private Const SM_SCREENY = 0
Private Const msgCancel = "."
Private Const msgNoXlInstance = "."
Private Const sigProc = "Drag & Drop"
Private Const VK_SHIFT = &H10
Private Const VK_CTRL = &H11
Private Const VK_ALT = &H12

Public Type PointAPI
  X As Long
  Y As Long
End Type

Public Type RECT
  lLeft As Long
  lTop As Long
  lRight As Long
  lBottom As Long
End Type

Public Type SquareEnd
  X As Long
  Y As Long
End Type

#If VBA7 Then
  Public Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As LongPtr) As Integer
  Public Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As LongPtr, ByVal yPoint As LongPtr) As LongPtr
  Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As LongPtr
  Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As LongPtr
  Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongPtr) As LongPtr
#Else
  Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
  Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
  Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Public mPoint As PointAPI
Private ActiveShape As Shape
Private dragMode As Boolean
Private dx As Double, dy As Double
Private sqrBlack As SquareEnd



Sub DragAndDrop(selectedShape As Shape)

  dragMode = Not dragMode
  DoEvents

  If selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy

  dx = GetSystemMetrics(SM_SCREENX)
  dy = GetSystemMetrics(SM_SCREENY)

  sqrBlack.X = ActivePresentation.Slides(1).Shapes("square_end").left
  sqrBlack.Y = ActivePresentation.Slides(1).Shapes("square_end").top

  Drag selectedShape


  If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Paste
  DoEvents
End Sub

Private Sub Drag(selectedShape As Shape)
  #If VBA7 Then
    Dim mWnd As LongPtr
  #Else
    Dim mWnd As Long
  #End If
  Dim sx As Long, sy As Long
  Dim WR As RECT
  Dim StartTime As Single

  Const DropInSeconds = 5


  GetCursorPos mPoint

  mWnd = WindowFromPoint(mPoint.X, mPoint.Y)

  GetWindowRect mWnd, WR
  sx = WR.lLeft
  sy = WR.lTop
  Debug.Print sx, sy

  With ActivePresentation.PageSetup
    dx = (WR.lRight - WR.lLeft) / .SlideWidth
    dy = (WR.lBottom - WR.lTop) / .SlideHeight
    Select Case True
      Case dx > dy
        sx = sx + (dx - dy) * .SlideWidth / 2
        dx = dy
      Case dy > dx
        sy = sy + (dy - dx) * .SlideHeight / 2
        dy = dx
    End Select
  End With

  StartTime = Timer

  While dragMode
    GetCursorPos mPoint
    selectedShape.left = (mPoint.X - sx) / dx - selectedShape.Width / 2
    selectedShape.top = (mPoint.Y - sy) / dy - selectedShape.Height / 2

    Dim left As Integer
    Dim top As Integer
    left = selectedShape.left
    top = selectedShape.top

    ActivePresentation.Slides(1).Shapes("position").TextFrame.TextRange = "X: " + CStr(left) + " Y:" + CStr(top)

     With sqrBlack

        ActivePresentation.Slides(1).Shapes("position_end").TextFrame.TextRange = "X:" + CStr(.X) + " Y:" + CStr(.Y)

     End With




         ActivePresentation.Slides(1).Shapes("label1").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))

    DoEvents
    If Timer > StartTime + DropInSeconds Then
     dragMode = False

     With ActivePresentation.Slides(1).Shapes("square_end") '
         If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And (selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
           dragMode = False
        End If
     End With




    End If

  Wend
  DoEvents
End Sub