使用Visual Basic宏实现PPT演示过程中图像的“拖动”（瞬移）

最新推荐文章于 2024-04-19 15:31:31 发布

cramming

最新推荐文章于 2024-04-19 15:31:31 发布

阅读量2k

点赞数 2

文章标签： powerpoint

本文链接：https://blog.csdn.net/cramming/article/details/130022981

版权

新建.pptx，更改后缀为.pptm
设置PPT允许运行宏：文件->左下选项->信任中心设置->启动宏
启用开发工具选项：文件->左下选项->自定义功能->开发工具
开发工具->Visual Basic->右键新建模块->粘贴宏代码
为图片加入动作：插入->动作->单击时运行宏（多张图就都设置一下）

宏

'启用选项显式声明，要求声明所有使用的变量
Option Explicit

' 使用WindowsAPI
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long


Type POINTAPI
    x As Long
    y As Long
End Type

Dim dragMode As Boolean     '当前拖动状态
Const SM_CXSCREEN = 0       '屏幕像素宽
Const SM_CYSCREEN = 1       '高


' 点击图片切换状态
Sub ImageClicked(sh As Shape)
    dragMode = Not dragMode
    If dragMode Then Drag sh
End Sub

' 可拖动则开始拖动
Private Sub Drag(sh As Shape)
    Dim imgX As Integer, imgY As Integer  '图像位置
    Dim presWidth As Long           '演示窗口大小
    Dim presHeight As Long
    Dim screenWidth As Long         '屏幕大小
    Dim screenHeight As Long
    Dim ratioWidth As Double        '比例
    Dim ratioHeight As Double
    
    Dim oldX As Long
    Dim oldY As Long
    Dim cursorPos As POINTAPI       '鼠标位置
    
    ' 获取当前鼠标在屏幕上的位置
    Call GetCursorPos(cursorPos)
    oldX = cursorPos.x
    oldY = cursorPos.y
    
    imgX = sh.Left
    imgY = sh.Top
    ' MsgBox "图像左上" & x & "," & y
    
    presWidth = ActivePresentation.SlideMaster.Width
    presHeight = ActivePresentation.SlideMaster.Height
    ' MsgBox "演示文稿大小：" & presWidth & " x " & presHeight  '(960,540)
    
    screenWidth = GetSystemMetrics(SM_CXSCREEN)
    screenHeight = GetSystemMetrics(SM_CYSCREEN)
    ' MsgBox "屏幕大小：" & screenWidth & " x " & screenHeight    '(1920, 1080)
    
    ratioWidth = screenWidth / presWidth
    ratioHeight = screenHeight / presHeight
    ' MsgBox "ratio : " & ratioWidth & "," & ratioHeight
            
    Dim i As Integer
    i = 0

    While dragMode
        Call GetCursorPos(cursorPos)
        sh.Left = imgX + (cursorPos.x - oldX) / ratioWidth
        sh.Top = imgY + (cursorPos.y - oldY) / ratioHeight
        
        i = i + 1: If i > 1000 Then dragMode = False: Exit Sub
        ' DoEvents
    Wend
    
End Sub

说明

在运行visual basic宏的时候似乎是阻塞其他，所以图像不会及时刷新，但是使用DoEvents交还控制权给操作系统来处理这些绘图事件又会显得卡顿，所以还是放弃连续拖动，直接瞬移吧
方法非常的蠢，循环了1000次持续捕捉鼠标位置并更新图像位置，所以可供拖动的时间可能受电脑处理速度影响，可以自己调整倒数第3行循环次数 If i>1000