PPT播放状态下拖动图片的宏设置后没反应

cjh2705

从网上下载了一段宏代码，创建宏后，根据提示动作设置，但之后在运行时没有反应，求教代码是否有问题，该如何修改操作。谢谢高手。

Option Explicit

Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function windowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetwindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function MonitorFromPoint Lib "user32.dll" (ByVal X As Long, ByVal Y As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long


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


Private Type PointAPI
    X As Long
    Y As Long
End Type

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


Public mPoint As PointAPI, dPoint As PointAPI
Public ActiveShape As Shape
Dim dragMode As Boolean
Dim dx As Double, dy As Double


Sub DragandDrop(sh As Shape)

dragMode = Not dragMode
If dragMode Then Drag sh

End Sub


Private Sub Drag(sh As Shape)
Dim i As Integer, sx As Integer, sy As Integer
Dim mWnd As Long, WR As RECT

dx = GetSystemMetrics(SM_SCREENX): dPoint.X = dx
dy = GetSystemMetrics(SM_SCREENY): dPoint.Y = dy


GetCursorPos mPoint
With ActivePresentation.SlideShowwindow
    mWnd = windowFromPoint(mPoint.X, mPoint.Y)
    GetwindowRect mWnd, WR
    sx = WR.Left
    sy = WR.Top
    dx = (WR.Right - WR.Left) / ActivePresentation.PageSetup.SlideWidth
    dy = (WR.Bottom - WR.Top) / ActivePresentation.PageSetup.SlideHeight
End With


If dx > dy Then
    sx = sx + (dx - dy) * ActivePresentation.PageSetup.SlideWidth / 2
    dx = dy
End If
If dy > dx Then
    sy = sy + (dy - dx) * ActivePresentation.PageSetup.SlideHeight / 2
    dy = dx
End If


While dragMode
    GetCursorPos mPoint
    sh.Left = (mPoint.X - sx) / dx - sh.Width / 2
    sh.Top = (mPoint.Y - sy) / dy - sh.Height / 2
    DoEvents
    i = i + 1: If i > 2000 Then dragMode = False: Exit Sub
Wend

End Sub

cjh2705

哪位大神帮帮忙呀