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

Simple Node Code

I've seen loads of solutions to building slide shows that use a callout that has a speech tag that points to the item of interest on the slideshow page. All of them include many many slides and navigation cobwebs. The simplest way I have found to do this is by using an array, an if statement and the ".Nodes.SetPosition" method. I won't show all the code for that here, that will be saved for a book I'll publish later down the track. But with this VBA most of you will get the picture. Firstly add a callout to your slide and right click on it and choose the "Edit Points" option. Then move the point at the tip of the callout tag the one with the yellow point. This will convert the callout to a code editable object. Now on the top ribbon choose the developer tab and then select the macro icon. If you can't see the developer tab in the ribbon, a quick Google search will bring up a bunch of tutorials on what to do to make it available and how to turn
Post a Comment
Read more

Button States From A Table

I was asked recently to create a button that would have different states ( normal, hover over, down ). My first thought was to just use a command button from the developer tab. But they are pretty bland and somewhat clunky 1980's PC designed. I remembered a couple of ways that I have updated slide data before, sometimes from a table or another shape, both are very flexible techniques. The technique I'll show here is the table technique it is very straightforward and a creative mind will easily see the possibilities for more interesting uses. 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. Then create another shape and make it larger than your butt
Post a Comment
Read more

Why PowerPoint?

To begin with, I don't know of any other software that is capable of creating standalone multimedia interfaces that are self-serving ( no host needed ) and available to most everybody with a PC. I know of Apache and Lybra Open Office but in the company I work, they are not readily available or liked. PowerPoint is on every machine in our organisation and is considered an enterprise solution that is secure and stable. Nearly everyone around the world is moving away from swf and actionscript, something I am remorseful about. I had fun using AS2 and AS3. Adobe Flash was one of the better animation tools around. I have looked at Adobe Animate and it's still a good animation software but the html5 that it outputs is not fully compatible with every browser. In fact in most cases with html5 there is an awful lot that can go wrong. If you want standalone apps, for instance, you are severely encumbered. PowerPoint at least for me, ticks all the boxes. It has a great variety of illustrat
Post a Comment
Read more