What code will let me drag and drop shapes in presentation mode for PowerPoint?

Question

I would like to be able to drag and drop various objects in my slide presentation. It's for an interactive map where other people would choose where certain objects would be placed. This is not for a quiz, there are no right or wrong answers and I don't need a timer. Just the simple ability to move shapes around on the slide. I understand there is a Classroom add-in that lets you mark objects as drag-able, but the toolbar for this doesn't show up on the correct screen (I would need it on the presenter's screen not the main slideshow screen). I am not proficient in coding, and the tutorials I've found are not quite what I'm looking for (they have much more bells and whistles than Drag and Drop and are usually for quizzes) I don't have the ability to simplify these down to something I can use.

Answer 1

Hi @Sam

Please press Alt + F11, you may copy following code into one Module.

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

Then save it as one .pptm file.

Go to Insert tab > Illustration group > Shapes option > Blank Action Button, then draw one shape. Choose "Run macro: DragandDrop", click "OK".

And then, you may format this shape, fill in the picture you want, set the background to transparent, and have no outer border line.

You can create multiple action shapes. During the show, click on a shape, you can move it. When it reaches the desired position, stay there for a while and then move it to the next one.

---

If the answer is helpful, please click "Accept Answer" and kindly upvote it. If you have extra questions about this answer, please click "Comment".

Note: Please follow the steps in our documentation to enable e-mail notifications if you want to receive the related email notification for this thread.

---