Skip to main content

4 Awesome PowerPoint Drag and Drop Tutorials


I have done drag and drop differently in the past but this will now be my new go to script for all my projects in the future. Check it out for yourself.


'//////////////////////////////////////////////////////////////////////This is the code

Option Explicit
Private Const SM_SCREENX = 1
Private Const SM_SCREENY = 0
Private Const msgCancel = "."
Private Const msgNoXlInstance = "."
Private Const sigProc = "Drag & Drop"
Private Const VK_SHIFT = &H10
Private Const VK_CTRL = &H11
Private Const VK_ALT = &H12
Public Type PointAPI
 X As Long
 Y As Long
End Type
 
Public Type RECT
 lLeft As Long
 lTop As Long
 lRight As Long
 lBottom As Long
End Type
Public Type SquareEnd
 X As Long
 Y As Long
End Type
#If VBA7 Then
 Public Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As LongPtr) As Integer
 Public Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As LongPtr, ByVal yPoint As LongPtr) As LongPtr
 Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As LongPtr
 Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As LongPtr
 Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongPtr) As LongPtr
#Else
 Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
 Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
 Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
 Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
 Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If
Public mPoint As PointAPI
Private ActiveShape As Shape
Private dragMode As Boolean
Private dx As Double, dy As Double
Private sqrBlack As SquareEnd


Sub DragAndDrop(selectedShape As Shape)
 
 dragMode = Not dragMode
 DoEvents
 ' If the shape has text and we're starting to drag, copy it with its formatting to the clipboard
 If selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy
 
 dx = GetSystemMetrics(SM_SCREENX)
 dy = GetSystemMetrics(SM_SCREENY)
 
 sqrBlack.X = ActivePresentation.Slides(1).Shapes("square_end").left
 sqrBlack.Y = ActivePresentation.Slides(1).Shapes("square_end").top
 
 Drag selectedShape
 ' Paste the original text while maintaining its formatting, back to the shape
 If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Paste
 DoEvents
End Sub
Private Sub Drag(selectedShape As Shape)
 #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 ' Slide Show Window rectangle
 Dim StartTime As Single
 ' Change this value to change the timer to automatically drop the shape (can by integer or decimal)
 Const DropInSeconds = ADD_TIME_TO_DROP_HERE
 
 ' Get the system cursor coordinates
 GetCursorPos mPoint
 ' Find a handle to the window that the cursor is over
 mWnd = WindowFromPoint(mPoint.X, mPoint.Y)
 ' Get the dimensions of the window
 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
   
ActivePresentation.Slides(1).Shapes(ADD_SHAPE_TO_DISPLAY_POSITION_HERE).TextFrame.TextRange = "X: " + CStr(left) + " Y:" + CStr(top)
     
    With sqrBlack
     
       ActivePresentation.Slides(1).Shapes(ADD_SHAPE_TO_DISPLAY_END_POSITION_HERE).TextFrame.TextRange = "X:" + CStr(.X) + " Y:" + CStr(.Y)
       
    End With
       
       
       
   ' Comment out the next line if you do NOT want to show the countdown text within the shape
   If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
    
        ActivePresentation.Slides(1).Shapes(ADD_SHAPE_NAME_FOR_COUNTDOWN_HERE).TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
   
   DoEvents
   If Timer > StartTime + DropInSeconds Then
    dragMode = False     
    With ActivePresentation.Slides(1).Shapes(ADD_GOAL_SHAPE_NAME_HERE) ' EXAMPLE:square_end is where you want the square to land
        If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And (selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
          MsgBox ADD_MESSAGE_HERE
       End If
    End With
    
    
    
    
   End If
   
 Wend
 DoEvents
End Sub

Comments

Post a Comment

Popular posts from this blog

Button States From A Table

I was recently asked to create a button with different visual states — normal , hover , and pressed . My first thought was to use a standard command button from the Developer tab. However, those buttons are rather bland and have that clunky 1980s PC look. I then recalled a couple of techniques I’ve used before to update slide content dynamically — either pulling data from a table or from another shape. Both are flexible approaches. The method I’ll show here uses a table — it’s simple, and with a bit of creativity, you’ll quickly see how this can be extended to build much more interesting interactions. The Process: On any slide create a shape I've put mine on the first slide hence in the script it reads ActivePresentation.Slides(1) when I refer to the path of the shape. You can change the number if your shape is on a different slide. Once you create your shape in the Selection Pane rename your object to myButton or something else that you can remember easily later. ...
Post a Comment
Read more

Why PowerPoint?

To begin with, I’m not aware of any other software that can create fully standalone multimedia interfaces — self-contained, requiring no external host — that are as widely accessible to PC users. While I know of tools like Apache or LibreOffice, they are neither popular nor readily supported in the organisation I work for. PowerPoint, on the other hand, is installed on every machine and regarded as an enterprise-grade solution — stable, secure, and universally accepted. It’s a shame that the world has largely moved away from SWF and ActionScript. I really enjoyed developing with AS2 and AS3 — Adobe Flash was one of the best animation tools around. I’ve explored Adobe Animate, which remains a good animation platform, but its HTML5 output isn’t consistently reliable across all browsers. In fact, a lot can go wrong with HTML5, especially when you want to create standalone applications — the limitations quickly become apparent. For me, PowerPoint still ticks all the boxes. It offers an exc...
Post a Comment
Read more