实现在PPT演示过程中-用鼠标拖动图片

实现在PPT 演示过程中，用鼠标拖动图

片

1 ．新建一个ppt 空白文档。

2．点击菜单：“工具——宏——宏” ，出现对话框。

3．对话框中“宏名”写：drop (其他也可以) ，再点“创建” ，就进入代码模式。

4 ．“Sub drop()'

''End Sub ”，类似的三句全删掉。把下面的代码全拷贝进去。

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.T op

dx = (WR.Right - WR.Left) / ActivePresentation.PageSetup.SlideWidth

dy = (WR.Bottom - WR.T op) / 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

5 ．点击保存后，关闭代码模式，回到ppt 设计页面。在你需要拖动的图片上点右键，选择

“动作设置——单击鼠标——运行宏——确定” 。然后就看效果吧。