如果有需要在PPT演示過程中簡單拖拽一些元素的功能，那麼這篇文章絕對能幫助你

   在上一篇文章分泌蛋白過程操作動畫中提及到實現PPT演示過程中拖拽元素的方法，這篇寫出詳細過程。

   先說明幾點：    1、完成後的PPT必須儲存為字尾pptm，而不能是pptx\ppt等，不影響播放    2、可拖拽的物件不能有動畫，否則會混亂

支援透明背景

1. 顯示開發工具： 【檔案】-【選項】-【自定義功能區】-右側主選項卡勾選【開發工具】-【確定】

回到PPT就會顯示開發工具

2. 允許巨集設定：【檔案】-【選項】-【信任中心】-【信任中心設定】-【巨集設定】-勾選【啟用所有巨集】-勾選【信任VBA工程物件模型的訪問】-【確定】

3. 開啟巨集： 【開發工具】-【巨集】-【隨便輸入名稱】-【建立】 就會得到程式設計區

4. 輸入程式碼儲存： 先刪除原來的所有程式碼，再輸入以下程式碼：

Option Explicit
Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Function MonitorFromPoint Lib "user32.dll" (ByVal x As Long, ByVal y As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe 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
 

點選儲存，此時會另存為檔案，一定要選pptm字尾，隨後關閉程式設計區

6. 新建動作按鈕並設定巨集：【插入】-【形狀】-最下欄動作按鈕最右邊【自定義動作】 插入後，會彈出動作設定（超連結）視窗，選擇執行巨集，確定
7. 換成自己的形狀/圖片： 【準備好PNG圖片】-【複製PNG圖片】-【右擊動作按鈕】-【設定形狀格式】-【填充】-【圖片或紋理填充】-【剪下板】

得到透明背景的動作按鈕

下面進行一下潤色 點選動作按鈕，【繪圖工具】-【輪廓】-【無輪廓】

得到無輪廓無背景動作按鈕

只要稍微拉伸一下動作按鈕，就能得到相同的圖片效果

9. 演示的操作： 點選一下目標（不需要長按），目標就會跟隨滑鼠移到，再次點選，目標就會在滑鼠處落下。如果需要多個目標，則進行相同的步驟即可。