PowerPoint VBA拖拽功能代码适配多幻灯片修改咨询

问题根因 #

你之前调整后功能失效的核心原因是ActivePresentation.View.Slide仅在普通编辑视图下能正常返回当前幻灯片，进入幻灯片放映模式运行游戏时，视图对象类型会发生变更，调用该属性会触发运行时错误，直接导致拖拽逻辑全部中断。

适配方案 #

核心逻辑：完全放弃通过视图属性获取当前幻灯片，直接从触发拖拽事件的形状对象读取它所属的幻灯片，该引用不受视图模式影响，准确率100%

调整要点 #

1. 在DragAndDrop过程中先通过selectedShape.Parent获取当前幻灯片对象
2. 给Drag过程新增参数，传入获取到的当前幻灯片对象
3. 替换原代码中所有硬编码幻灯片索引、通过视图获取幻灯片的引用逻辑

修改后完整代码 #

首先请保留你原有模块顶部的API声明、公共变量（包括dragMode、objStart、objEnd、mPoint、RECT结构体定义、GetSystemMetrics/GetCursorPos等API声明）不要改动，仅替换下面两个子过程的代码即可：

Sub DragAndDrop(selectedShape As Shape)
    ' 直接从形状对象获取所属幻灯片，无需依赖视图
    Dim currentSlide As Slide
    Set currentSlide = selectedShape.Parent
    
    Dim obj_end As String
    obj_end = selectedShape.Name & "_end"
  
    dragMode = Not dragMode
    DoEvents
    ' 拖拽开始时复制原文本格式
    If selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy
  
    dx = GetSystemMetrics(SM_SCREENX)
    dy = GetSystemMetrics(SM_SCREENY)
  
    ' 记录形状初始位置
    objStart.X = selectedShape.left
    objStart.Y = selectedShape.top
  
    ' 用当前幻灯片对象读取目标位置
    objEnd.X = currentSlide.Shapes(obj_end).left
    objEnd.Y = currentSlide.Shapes(obj_end).top
  
    ' 把当前幻灯片传入Drag过程
    Drag selectedShape, currentSlide

    ' 拖拽结束后恢复原文本
    If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Paste
    DoEvents
End Sub


 
Private Sub Drag(selectedShape As Shape, ByVal currentSlide As Slide)
  #If VBA7 Then
    Dim mWnd As LongPtr
  #Else
    Dim mWnd As Long
  #End If
  Dim sx As Long, sy As Long
  Dim WR As RECT ' 放映窗口矩形
  Dim StartTime As Single
  ' 自动松开的倒计时时长，可自行调整
  Const DropInSeconds = 2
  
  ' 获取鼠标坐标
  GetCursorPos mPoint
  mWnd = WindowFromPoint(mPoint.X, mPoint.Y)
  GetWindowRect mWnd, WR
  sx = WR.lLeft
  sy = WR.lTop
  Debug.Print sx, sy
  
  With ActivePresentation.PageSetup
    dx = (WR.lRight - WR.lLeft) / .SlideWidth
    dy = (WR.lBottom - WR.lTop) / .SlideHeight
    Select Case True
      Case dx > dy
        sx = sx + (dx - dy) * .SlideWidth / 2
        dx = dy
      Case dy > dx
        sy = sy + (dy - dx) * .SlideHeight / 2
        dy = dx
    End Select
  End With
 
  StartTime = Timer
  
  While dragMode
    GetCursorPos mPoint
    selectedShape.left = (mPoint.X - sx) / dx - selectedShape.Width / 2
    selectedShape.top = (mPoint.Y - sy) / dy - selectedShape.Height / 2
    
    Dim left As Integer
    Dim top As Integer
    left = selectedShape.left
    top = selectedShape.top
        
    ' 不需要形状内显示倒计时可以注释下一行
    If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
    ' 更新倒计时文本
    currentSlide.Shapes("lblInfo").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
         
    DoEvents
    If Timer > StartTime + DropInSeconds Then
     dragMode = False

     With currentSlide.Shapes(obj_end)
         ' 判断是否拖入目标区域
         If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And (selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
           currentSlide.Shapes("talk").TextFrame.TextRange = "Got it! Great job!"
           'totalPoints = totalPoints + 1  需要累计分数可以取消注释
         Else
         ' 拖错位置回归原位
           selectedShape.left = objStart.X
           selectedShape.top = objStart.Y
           currentSlide.Shapes("talk").TextFrame.TextRange = "Sorry! Try again!"
        End If
     End With
     
    End If
  Wend
  DoEvents
End Sub

注意事项 #

• 所有游戏幻灯片的配套元素命名必须统一：可拖拽形状对应的目标区域命名为[拖拽形状名称]_end，同时每张幻灯片必须包含命名为lblInfo的倒计时文本框、命名为talk的提示文本框
• 每个幻灯片上的可拖拽形状都要在「动作设置」里绑定DragAndDrop宏，点击/鼠标悬停触发都可以
• 如果不需要跨幻灯片累计分数，可以不用修改全局变量逻辑，每张幻灯片的游戏逻辑完全独立

内容的提问来源于stack exchange，提问作者Malcolm Kenworthy