Select Page

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.

Download Drag & Drop pptm

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