Mover objetos con tiempo y cuadro de confirmacion

Nota: Para que el código funcione es necesario variar de los parámetros destacados en los colores (cian y amarillo)
Sera necesario editar esos parámetros dependiendo de la diapositiva donde nos encontremos y el recuadro donde se
ubicara la respuesta correcta, luego solo restara aplicar ese macro por medio de una acción al elemento que queramos
mover a una determinada respuesta, para que luego aparezca el mensaje de confirmación (ej. ¨Correcto¨)…

Cosas indispensables para que funcione correctamente:

1- Hara falta crear los recuadros de position , position_end , reloj, y el de square_end, este último por lo menos una
vez para que funcione el movimiento, (si no se quiere que se vean se los puede ocultar o llevar afuera de la
diapositiva para que queden ocultos en la presentación)

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 selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy

dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)

sqrBlack.X = ActivePresentation.Slides(5).Shapes("square_end1").left
sqrBlack.Y = ActivePresentation.Slides(5).Shapes("square_end1").top

Drag selectedShape

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
Dim StartTime As Single

Const DropInSeconds = 3 ACA PONER LA CANTIDAD DE SEGUNDOS PARA RESPONDER (en segundos)

GetCursorPos mPoint

mWnd = WindowFromPoint(mPoint.X, mPoint.Y)

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(5).Shapes("position").TextFrame.TextRange = "X: " + CStr(left) + " Y:" + CStr(top)

With sqrBlack

ActivePresentation.Slides(5).Shapes("position_end").TextFrame.TextRange = "X:" + CStr(.X) + " Y:" + CStr(.Y)

 End With

If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))

ActivePresentation.Slides(5).Shapes("NOMBRE DEL RECUADRO DONDE APARECE EL TIEMPO").TextFrame.TextRange.Text =

CInt(DropInSeconds - (Timer - StartTime))

DoEvents
If Timer > StartTime + DropInSeconds Then
dragMode = False

With ActivePresentation.Slides(5).Shapes("square_end1")
If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And
(selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
MsgBox "Correcto!!!" ACA PONER EL MENSAJE QUE QUERES QUE APAREZCA (entre comillas)
End If
End With

End If

Wend
DoEvents
End Sub

------------------------------------------------------------------------------------------------
Copiar y pegar el Código anterior

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 selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy

dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)

sqrBlack.X = ActivePresentation.Slides(3).Shapes("square_end1").left
sqrBlack.Y = ActivePresentation.Slides(3).Shapes("square_end1").top

Drag selectedShape

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
Dim StartTime As Single

Const DropInSeconds = 3

GetCursorPos mPoint

mWnd = WindowFromPoint(mPoint.X, mPoint.Y)

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(3).Shapes("position").TextFrame.TextRange = "X: " + CStr(left) + " Y:" + CStr(top)

With sqrBlack

ActivePresentation.Slides(3).Shapes("position_end").TextFrame.TextRange = "X:" + CStr(.X) + " Y:" + CStr(.Y)

End With

If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))

ActivePresentation.Slides(3).Shapes("reloj").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))

DoEvents
If Timer > StartTime + DropInSeconds Then
dragMode = False

With ActivePresentation.Slides(3).Shapes("square_end1")
If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And
(selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
MsgBox "Correcto!!!"
End If
End With

End If

Wend
DoEvents
End Sub

------------------------------------------------------------------------------------------------

Solo mover objetos

Nota: La variación de los parámetros destacados en colores (cian y amarillo) es indistinta, solo bastara con crear un
modulo y aplicar ese macro por medio de una acción al elemento que queramos mover…

Cosas indispensables para que funcione correctamente:

 2- Lo mas importante será cambiar la cantidad de segundos a 99 (destacada en verde) para que al arrastrar el objeto
este no se suelte automáticamente al terminar el tiempo, sino que seamos nosotros quienes lo soltemos haciendo
un clic (a veces hace falta un clic sostenido)
3- Hara falta crear los recuadros de position , position_end , reloj, y el de square_end, este ultimo por lo menos una
vez para que funcione el movimiento, (si no se quiere que se vean se los puede ocultar o llevar afuera de la
diapositiva para que queden ocultos en la presentacion)

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 selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy

dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)

sqrBlack.X = ActivePresentation.Slides(5).Shapes("square_end1").left
sqrBlack.Y = ActivePresentation.Slides(5).Shapes("square_end1").top
 Drag selectedShape

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
Dim StartTime As Single

Const DropInSeconds = 99 ACA PONER LA CANTIDAD DE SEGUNDOS PARA RESPONDER (en segundos)

GetCursorPos mPoint

mWnd = WindowFromPoint(mPoint.X, mPoint.Y)

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(5).Shapes("position").TextFrame.TextRange = "X: " + CStr(left) + " Y:" + CStr(top)

With sqrBlack

ActivePresentation.Slides(5).Shapes("position_end").TextFrame.TextRange = "X:" + CStr(.X) + " Y:" + CStr(.Y)

End With

If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))

 ActivePresentation.Slides(5).Shapes("NOMBRE DEL RECUADRO DONDE APARECE EL TIEMPO").TextFrame.TextRange.Text =
CInt(DropInSeconds - (Timer - StartTime))

DoEvents
If Timer > StartTime + DropInSeconds Then
dragMode = False

With ActivePresentation.Slides(5).Shapes("square_end1")
If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And
(selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
MsgBox "Correcto!!!" ACA PONER EL MENSAJE QUE QUERES QUE APAREZCA (entre comillas)
End If
End With

End If

Wend
DoEvents
End Sub

------------------------------------------------------------------------------------------------
Copiar y pegar el Código anterior

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 selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy

dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)

sqrBlack.X = ActivePresentation.Slides(3).Shapes("square_end1").left
sqrBlack.Y = ActivePresentation.Slides(3).Shapes("square_end1").top

Drag selectedShape

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
Dim StartTime As Single

Const DropInSeconds = 99

GetCursorPos mPoint

mWnd = WindowFromPoint(mPoint.X, mPoint.Y)

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(3).Shapes("position").TextFrame.TextRange = "X: " + CStr(left) + " Y:" + CStr(top)

With sqrBlack

ActivePresentation.Slides(3).Shapes("position_end").TextFrame.TextRange = "X:" + CStr(.X) + " Y:" + CStr(.Y)

End With

If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))

ActivePresentation.Slides(3).Shapes("reloj").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))

DoEvents
If Timer > StartTime + DropInSeconds Then
dragMode = False

With ActivePresentation.Slides(3).Shapes("square_end1")
If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And
(selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
MsgBox "Correcto!!!"
End If
End With

End If

Wend
DoEvents
End Sub

------------------------------------------------------------------------------------------------

INTENTAAAA

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