VBA code in Powerpoint 2007 stopped working with PowerPoint 2010

[rbotelho]

Hi all,

I need help please! I am a teacher and I developed a board game about 2 years ago to play with my children on the classroom.

The code allows to move shapes during slide show using the mouse. The process to move the shape would be to click the shape to pick it up, then move the mouse to place the shape at a new location and then finally click the shape again to drop it at that new location.

This code was taken from an example that exists in this website: http://officeone.mvps.org/vba/mousemove_shape.html


The logic is:

1. Set MouseClick action setting of a shape to the a MoveShape macro.
2. The MoveShape macro
   1. Sets moving to true when you click the shape the first time.
   2. Notes down the shape's location in OrigShpLeft and OrigShpTop variables and also the mouse location in OrigMouseLocation variable. A key point to note here is that while the values of OrigShpLeft and OrigShpTop are relative to the slide and in points, the OrigMouseLocation is relative to the desktop and in pixels. So, when we want to calculate the new location for the shape, we need to convert the mouse coordinates by converting from pixels to points as described in ConvertPixelsToPoints macro.
   3. Start a timer that runs a procedure every 10 milliseconds. The timer macro looks-up the current mouse position and calculates the difference from the original position. This difference is applied to the shape's position thus moving the shape to follow the mouse.

Everything worked great until we updated our school PCs to Office 2010. The game stopped working properly.

At this moment I click on the shape and I still can move it to the new square on the board, but when I click again to set the shape to the new position and stop moving it, it doesn't work and the shape continues to move with the mouse.

Can anyone please help us?

Below is the code that stopped working (mouse click to stop moving the shape):

Option Explicit
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hDC As Long, _
    ByVal nIndex As Long) As Long
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const TWIPSPERINCH = 1440
Private Declare Function SetTimer Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _
    ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal nIDEvent As Long) As Long
Type Point
    X As Long
    Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As Point) As Long
Private XPixelsPerInch As Long
Private YPixelsPerInch As Long
Private Ratio As Single
Private Moving As Boolean
Private DragShp As Shape
Private TimerId As Long
Private HostObj As HostClass
Private OrigShpLeft As Single
Private OrigShpTop As Single
Private OrigMouseLocation As Point
Sub MoveShape(ByVal Shp As Shape)
    Dim hDC As Long
    On Error Resume Next
    If SlideShowWindows.Count > 0 Then
        If Moving Then
            EndMoveShape
        Else
            hDC = GetDC(0)
            XPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
            YPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
            ReleaseDC 0, hDC
    
            Ratio = Shp.Parent.Parent.SlideShowWindow.View.Zoom / 100#
    
            Set DragShp = Shp
            OrigShpLeft = Shp.Left
            OrigShpTop = Shp.Top
            GetCursorPos OrigMouseLocation
            StartTimer
            Moving = True
            Set HostObj = New HostClass
        End If
    End If
End Sub
Sub EndMoveShape()
    On Error Resume Next
    Set HostObj = Nothing
    Moving = False
    StopTimer
    Set DragShp = Nothing
End Sub
Private Sub StartTimer()
    On Error Resume Next
    TimerId = SetTimer(0, 0, 10, AddressOf TimerProc)
End Sub
Private Sub StopTimer()
    On Error Resume Next
    KillTimer 0, TimerId
End Sub
Private Sub TimerProc(ByVal hWnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long)
    Dim CurMouseLocation As Point
    Dim DeltaX As Single
    Dim DeltaY As Single
    On Error Resume Next
    If Moving Then
        GetCursorPos CurMouseLocation
        DeltaX = (CurMouseLocation.X - OrigMouseLocation.X) * _
            TWIPSPERINCH / 20 / XPixelsPerInch / Ratio
        DeltaY = (CurMouseLocation.Y - OrigMouseLocation.Y) * _
            TWIPSPERINCH / 20 / XPixelsPerInch / Ratio
        DragShp.Left = OrigShpLeft + DeltaX
        DragShp.Top = OrigShpTop + DeltaY
    End If
End Sub

Thanks to anyone who cares!