【PPT】2010/2013/2016实现在演示过程中拖拽图片/形状

2023-08-28 05:49| 来源: 网络整理| 查看: 265

如果有需要在PPT演示过程中简单拖拽一些元素的功能，那么这篇文章绝对能帮助你

在上一篇文章分泌蛋白过程操作动画中提及到实现PPT演示过程中拖拽元素的方法，这篇写出详细过程。

先说明几点： 1、完成后的PPT必须保存为后缀pptm，而不能是pptx\ppt等，不影响播放 2、可拖拽的对象不能有动画，否则会混乱

支持透明背景显示开发工具：【文件】-【选项】-【自定义功能区】-右侧主选项卡勾选【开发工具】-【确定】

回到PPT就会显示开发工具

允许宏设置：【文件】-【选项】-【信任中心】-【信任中心设置】-【宏设置】-勾选【启用所有宏】-勾选【信任VBA工程对象模型的访问】-【确定】

打开宏：【开发工具】-【宏】-【随便输入名称】-【创建】在这里插入图片描述

就会得到编程区

输入代码保存：先删除原来的所有代码，再输入以下代码： 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后缀，随后关闭编程区