http://www.rapidbbs.cn/forum.php?mod=viewthread&tid=79588

　　PPT在放映时是不能用鼠标拖动其对象的，往往不太方便，可以用VBA语言来实现放映时拖动对象的效果。下面是其代码，分为三部分：第一部分声明API语句和变量，第二部分是一个公开的DragandDrop函数，第三部分是私有函数Drag。在幻灯片设计视图下，选中要拖动的对象，然后在功能区的“插入”卡里选择“动作”，弹出对话框，选择“运行宏”，在下拉框里选DragandDrop。放映时如果要拖动对象，只要单击该对象就可以拖动了，再次单击该对象，就能退出拖动状态。

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