In this LinkedIn discussion, the question was asked if it was possible to update an existing macro to be compatible with PowerPoint 2010.
The original macro was written by Hans W. Hofmann and performed the following functions during a slide show:
Left-click on a shape to pick it up and move it, and then left-click a second time to drop it in its new position,
While holding Shift and Alt, left-click to calculate the text based formula within the shape.
The first mode doesn’t work correctly with PowerPoint 2010 because the second click is being intercepted by PowerPoint as a ‘next slide’ event rather than a macro On Mouse Click event. So, in the first instance, we have changed the code so that a 5 second timer is started when the shape is picked up and once that timer expires, the shape is dropped automatically.
The machine clock based timer replaces the original less robust timer with used the increment of a variable to count time before automatically dropping the shape. This was ok for PowerPoint 2007 and 2010 as it took around 30 to 40 seconds to count the time but only 1 second in PowerPoint 2013.
Download
You can download a presentation that contains the macro code below and try it for yourself.
Modified Code
' ===================================================================================
' Drag & Drop Macro
'
' Original code developed by Hans W. Hofmann
' Modified by Jamie Garroch of YOUpresent Ltd.
' Visit us online at http://youpresent.co.uk
'
' Standard operation during a slide show:
'
' Mode 1 : Left click a shape with the macro assigned to it to pick it up and move it.
' Click again to drop it (not working in PowerPoint 2010 so 5 second timer
' added as a temporary workaround which can be chagned by setting the constant
' "DropInSeconds" to a value in seconds in the below "Drag" procedure.
' Mode 2 : While holding Shift and Alt, left-click to calculate the text based formula
' within the shape.
' ===================================================================================
Option Explicit
Private Const SM_SCREENX = 0
Private Const SM_SCREENY = 1
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
#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
Public Sub MacroTest()
MsgBox "Macros are enabled!", vbInformation + vbOKOnly, "YOUpresent.co.uk"
End Sub
Sub DragAndDrop(oShp As Shape)
If CBool(GetKeyState(VK_SHIFT) And &HF0000000) And CBool(GetKeyState(VK_ALT) And &HF0000000) Then DragCalculate oShp: Exit Sub
dragMode = Not dragMode
DoEvents
' If the shape has text and we're starting to drag, copy it with its formatting to the clipboard
If oShp.HasTextFrame And dragMode Then oShp.TextFrame.TextRange.Copy
dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)
Drag oShp
' Paste the original text while maintaining its formatting, back to the shape
If oShp.HasTextFrame Then oShp.TextFrame.TextRange.Paste
DoEvents
End Sub
Private Sub Drag(oShp 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 = 3
' 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
oShp.Left = (mPoint.x - sx) / dx - oShp.Width / 2
oShp.Top = (mPoint.y - sy) / dy - oShp.Height / 2
' Comment out the next line if you do NOT want to show the countdown text within the shape
If oShp.HasTextFrame Then oShp.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
DoEvents
If Timer > StartTime + DropInSeconds Then dragMode = False
Wend
DoEvents
End Sub
Private Sub DragCalculate(oShp As Shape)
Dim xl As Object ' Late binding (no reference to Excel library required)
Dim FormulaArray
' If the shape has text in it then evaluate the formula else do nothing...
If oShp.HasTextFrame Then
' Create an Excel object
Set xl = CreateObject("Excel.Application") ' Late binding
If xl Is Nothing Then MsgBox msgNoXlInstance, vbCritical, "Quiz": Exit Sub
' Create an array of text strings by splitting the shape text concatenated with "=" using "=" as a delimiter
' The additon of "=" guarantees that the array has at least 2 elements, in positions 0 and 1
FormulaArray = Split(oShp.TextFrame.TextRange.Text & "=", "=")
' Replace all "," with "." in the first array entry (converting decimal format from EU to UK?)
While InStr(FormulaArray(0), ",") > 0
FormulaArray(0) = Replace(FormulaArray(0), ",", ".")
Wend
' If there is some text in the first array cell then Evaluate it using Excel and save the result in the 2nd array element
' Note: Evaluate is not an Excel function but a formula auditing tool which shows you exactly how the result is calculated
If FormulaArray(0) > "" Then
FormulaArray(1) = xl.Evaluate(FormulaArray)
' Concatenate the formula with the Evaluate text and save it back to the shape
oShp.TextFrame.TextRange.Text = FormulaArray(0) & "=" & FormulaArray(1)
End If
xl.Quit: Set xl = Nothing
' Nudge the shape up and back down to the same position (forcing the slide to be refreshed when DoEvents is called)
oShp.Top = oShp.Top + 1: oShp.Top = oShp.Top - 1
End If
DoEvents
End Sub
Original Code
Copyright Hans W. Hofmann
Option Explicit
'
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function MonitorFromPoint Lib "user32.dll" (ByVal x As Long, ByVal y As Long, ByVal dwFlags As Long) As Long
Private Const SM_SCREENX = 0
Private Const SM_SCREENY = 1
Private Const msgCancel = "."
Private Const msgNoXlInstance = "."
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
Public ActiveShape As Shape
Dim dragMode As Boolean
Dim dx As Double, dy As Double
Sub DragandDrop(sh As Shape)
If CBool(GetKeyState(VK_SHIFT) And &HF0000000) And CBool(GetKeyState(VK_ALT) And &HF0000000) Then DragCalculate sh: Exit Sub
dragMode = Not dragMode
DoEvents
Drag sh
DoEvents
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)
dy = GetSystemMetrics(SM_SCREENY)
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
Wend
DoEvents
End Sub
Private Sub DragCalculate(sh As Shape)
Dim xl As Object
Dim Formel
If sh.HasTextFrame Then
Set xl = CreateObject("Excel.Application")
If xl Is Nothing Then MsgBox msgNoXlInstance, vbCritical, "Quiz": Exit Sub
Formel = Split(sh.TextFrame.TextRange.Text & "=", "=")
While InStr(Formel(0), ",") > 0
Formel(0) = Replace(Formel(0), ",", ".")
Wend
If Formel(0) > "" Then
Formel(1) = xl.Evaluate(Formel)
sh.TextFrame.TextRange.Text = Formel(0) & "=" & Formel(1)
End If
xl.Quit
sh.Top = sh.Top + 1: sh.Top = sh.Top - 1
End If
DoEvents
End Sub
Great POST!
Hi there sir! I’m so happy to see this drag and drop version which now conveniently works for both 2010 and 2013 powerpoint versions! However, I still have some recommendations that I hope you could consider:
1. Please find a way to “add back” the other features of the improved drag and drag by Hanns Hoffman such as the “zoom in and out,” “rotate 45 degrees,” and “insert text” functions. In addition, please “retain” the old commands of these features (e.g. shift+left click was for rotating the object 45 degrees but now you have used shift+alt+left click for computation.)
2. Can you make the drag and drop macro “animation-friendly” since being an educator, I have been wanting to create a drag and drop activity that involves a timer. However, the moment I set the timer animation to start the moment I set the slide in slideshow mode, it is “halted” the moment I click an object with a drag and drop code. Hence, nullifying the added timer to begin with.
I would love to hear your response about these requests. Thank you so much once again and more power to you.
Aries from Philippines
We would be happy to help update our blog with the relevant code if we can locate it.
Do you have the code that performs the #1 functions above? If so, please could you send it to me and I will discuss it with our developers.
Ok sir, I will send you the code I have which runs in 2007 featuring those other drag and drop features. Sorry for replying just now for I have been so preoccupied with many things concerning my work here as an ICT teacher. I do hope you could really get them back to work again sir. They really make the drag and drop more useful in a wide array of subjects and purposes.;-)
Where do I send it by the way sir? Mind giving me an email address where I could do that? Thanks.
Hello sir… I’m also a teacher here in oriental mindoro… i’m new in macros… but i tried to learn it well coz i know it will help a lot to us teachers in teaching… for an interactive learning… can you pls help me for giving some guides in making ppt presentations using macros… my knowledge is just from video presentation in youtube and some articles like this… thank you sir…
We recommend you take a look around the VBA part of our blog. You could also purchase a good book on the subject such as “Mastering VBA for Microsoft Office”.
Hi, I’m a bit newbie with macros but I’ve downloaded your pptm and when I open the file, it seems the macro is not inside. When I open the file with powerpoint 2013 and I go to Developer/Macro, I haven’t any macro listed. Is it normal? i’m under windows 64bits.
Bonsoir Lionel. You won’t see the macro using the method you described as the procedures are either Private, Functions or contain Arguments that are passed to them. Only Procedures of type Sub, without Arguments, are listed in the view you mention. To see the full code, open the presentation and press Alt+F8. I’m not sure why it’s not working on your PC but you could check the macro security settings in the backstage (make sure you allow all macros – although we have started to digitally sign our code to increase the security). We will check the 64 Win (and 64 bit MSO) bit operation again tomorrow.
Sir Jamie, where do I send you the code. Please reply to my email add please….
Find a way to add back the original features of the old PowerPoint Drag and Drop macro….
Hi Aries Perez. We replied by email on 27 June 2014 but did not receive a reply from you. Did you receive it? The email came from the domain gmark.co and the subject was “YOUpresent.co.uk blog for drag & drop macro”
Ok, can you send me again a message where I can reply back with the code I was hoping you could modify for the 2010 ppt and beyond? I didn’t get the one you mentioned I’m afraid…
Alright, upon further checking, I think i even already sent to gmark.co the ppt file which contains the macro I was talking about! please care to check the email I sent you sir
I’ve just forgotten to say in my last post that drag and drop doesn’t work for me… this is why I’ve tried to investigate and to read the macro.
Hi Jamie,
Many thanks for your instructive reply.
Anyway, I’ve tried enabling temporarily all macros, but without any result on the drag and drop functionality. Have you had time to check under W64bits?
My wife is teacher, here in France, and she has asked to me if it was possible to drag and drop pictures in powerpoint… Just asking that to Google, I said “no problem” but now I’m a bit disapointed…
Hoping you understand my poor english, many thanks in advance
We found an issue with 64 bit PowerPoint and have corrected the macro. Please try again with the latest download/code.
Hi,
Goodevening.. Can anyone please help me. I am working on a Learning Object using Powerpoint 2013. My problem is I want to DragandDrop to add two numbers.
Example: 0 1 2 3 4 5 6 7 8 9
box 1: 2 (drag number from 0-9)
box 2: 3 (drag number from 0-9)
Total: 5
I have tried several time already and it taking me too long for this. I am not a programmer, I am just a student. Please help me how can I do that using ppt. and without error especially when i convert it in Ispring.
Thanks in advance.
It is possible to do this in PowerPoint using VBA (with modifications to the Drag & Drop macro) but it is not possible to convert with iSpring because iSpring only converts slide content and not code content. To implement a solution with iSpring would require deep knowledge of HTML5, CSS and JavaScript which is not part of what we offer.
Hi Jamie,
Is it possible to edit the code so that the spinning mouse circle doesn’t appear? Thanks for developing this – had been searching everywhere to find a working macro for ppt 2013!
Thanks!
Emma
It may be possible but it’s PowerPoint that is changing the mouse cursor while the drag loop is running. We can quote for what you require. Please use the Contact Us form if this is of interest.
is it possible to view this macro code for powerpoint on 2011 office for mac? I cannot get this code to work, even though I have attached it in the action settings. Any help would be great.
Hi Matthew. Unfortunately not because it uses more than the common set of VBA functions available in Office:mac, for example, Windows API functions.
Is it possible to modify this code to reject a drop from a specific area?
That could be possible Alex. The question would be how to set that area. By a shape, by a set of coordinates defining an area, per presentation or per slide etc. At present, we don’t have the capacity to look at this project just at the moment but will consider it in the future. Thank you for your suggestion.
Yes but as this is a free macro, we cannot provide you with a free solution. We can quote for what you require though. Please use the Contact Us form if this is of interest.
The only thing that happens is that the mouse pointer changes to a hand. I still can’t move anything around. Too bad.
We have updated the downloadable file with a macro test button after checking it with PowerPoint 2013. Please could you try again?
The “alt+shift left click” calculations worked – but not fast. And none of the other things work in Powerpoint 2013. But I did see the mouse pointer change to a hand in the mouse over macro.
The calculation is using Excel (in case a complex formula is entered) so the delay is the time required for Excel to start, process the formula and then close. Did you download the new file “YOUpresent-Drag-Drop-macro.pptm” as it’s working with 2013 for us?
Yes, I have tried with the new file several times and even made an object myself. Macros are enabled – I have checked inside the presentation and in Powerpoint settings too. I have downloaded it again to try again. And my Powerpoint version is 2013 and works perfectly with everything else. I am fairly certain this script will not work on every version of 2013.
I tried everything I could. Even took the script and made a new document by using it there. It doesn’t work in my Powerpoint 2013
We found an issue with 64 bit PowerPoint and have corrected the macro. Please try again with the latest download/code.
Dear Sir, dragging and dropping are exactly what I’ve been looking for for so long. It’s an ideal solution for a teacher to make simple but attractive exercises. Yet your sample presentation worked only under 2010, under MS Powerpoint 2013 all I managed to make work was holding Alt+ Shift to get an answer. Why is that so? Is there another version for 2013? If yes please share or give me a tip what I can do. Thanks in advance!
We have updated the downloadable file with a macro test button after checking it with PowerPoint 2013. Please could you try again?
Do you have a drag drop that work in ppt 2013, so far could not get it working
or perhaps code with full featured..
i am interested in this for some presentation purposes
We have updated the downloadable file with a macro test button after checking it with PowerPoint 2013. Please could you try again?
Yes, it is working perfectly. Thanks a lot !!!
I did check it Sir and I do not know what is wrong. On Office 2010 it still works like a charm and on Ppt 2013 there’s absolutely no reaction whatsoever, the rectangles remain unresponsive even though Macros are enabled. Maybe I need to change some other settings..
We found an issue with 64 bit PowerPoint and have corrected the macro. Please try again with the latest download/code.
It works!!! Wow, I have been searching for software that can make drag-and-drop documents for some time. Now it works. I click and can move the image around for 3 seconds and then repeat if I want to. I am planning to put earth, moon, pluto there so that people can compare the sizes of the countries.
YES! I confirm it is working! Hurray!
On the flipside: it’s not working as smoothly as with Power Point 2010, though. And each time I move the objects an hourglass appears , which I think was not the case with 2010.
But it is a huge MOVE FORWARD:) I hope you’ll still be improving 🙂
It’s me again! I’m still not using the macro on Ppt2013. The objects do move now, but the movement is ackward, lagging, not smooth or fluent. I’ve just checked the presentation again to see if anything has changed, but it’s still like this:(
Hi I am very much a novice when it comes to this.
I find that youpresent’s drag and drop is the most functional on the net. I would like to use it for PPTs to use with my students. However, when I try to change the design of my slides I still see a green background and the youpresent banner on the slides. How do I change this? If I need to sign up etc then I am more than willing to do so :-).
Many Thanks
Jason
Hi Jason. We’re not sure we understand “green background” because this macro does not change the design of any slides. Could you explain in more detail what you are doing?
Apologies. I should of been more clear.
You guys have provided the code but I have absolutely no idea how I would code this macro into my own PPT. In order to use this macro I have to use your PPT as the “base” in which to create my own presentations. The problem is whenever I try to change the background design the first slide is fine but the rest of the slides still have the youpresent banner and it retains some of the green background from your original presentation.
Am I able to attach pictures to these replies or have an email address so I can show screen shots of what I am experiencing?
Thanks for your help and patience with a super novice :-).
Jason
OK. Understood. This article should get you started porting macros to your own presentations.
hi, could just remove the 3 seconds timing and replace with a simply drop mode on releasemouse click? It also will be great if it could set a target area and then will snap over, else move back to its original place
Thanks for the suggestions gmel. We’re not developing this code at present but may look at this in the future. However, you are free to modify it as required.
It is great. I was stuck with Powerpoint 2010 onward on the Drag & Drop function. This code has come in very useful in developing interactive material using Powepoint.
Susil, Sri Lanka
Hello Sir,
I am trying to use the macro on an object “picture 2” that appears by clicking on “picture 1”. Each time I go to move “picture 2” with the macro, it resets “picture 1” and makes “picture 2” disappear. Is there a workaround for this? I cannot simply hide “picture 2” because it is significantly larger than “picture 1”, which acts as a small button to activate “picture 2”.
It’s probably possible to do what you are looking for Justin. You may modify this macro freely to customise it yourself or use our development service. If you require us to develop it further for you, please use our contact form to request a quotation.
When I create a shape and click on it then go to action then go to Run Macro, it does not allow me to open macro. Why is this happening.?
VBA may not be installed or active on your PC. Check this article : http://youpresent.co.uk/determining-vba-installed-microsoft-office/
Hi. hanks for uploading this. I have been trying to find out how to do this for some time now. After copying the code from your post to my 2016 Microsoft Office PPPT and ran it, my shape (one I created in the PPT) showed a hand as I moved my cursor over it, but that was all. Nothing else happened. What could the issue be?
When you click the shape in a slide show, it should then enter drag mode and it should move around. Make sure you have your security settings set appropriately ti allow VBA macros to run : File / Options / Trust Center / Trust Center Settings / Macro Settings
I tried running the original code and the modified code and neither seems to be working for me. I’m a noob so I may just be running this wrong. Any assistance would be much appreciated.
Can you check that VBA is working by inserting a simple Sub HelloWord() procedure with a single line MsgBox “Hello World” and pressing F5 to run it?
Thank you so much, you help me and my students a lot! you are awesome <3