Attribute VB_Name = "mDrag"

'(C)oded by HW 2005 ppt-user.de
'Purpose:
'Drag & Drop functionality for powerpoint shapes
'
'Installation:
'1. Extract the contents of the zip to a folder.
'2. Launch PowerPoint.
'3. OPen VBA-Editor Alt+F11.
'4. Click File menü to import the Module drag&drop.BAS
'5. Insert/draw the object that you want to move
'6. Right click on it and choose Action Settings.
'7  Simply set Run Macro to DragandDrop.
'8. Switch to slide show view,
'   to test and use the macro.


'Disclaimer:
'All of the files available in this download are provided as-is,
without any
'warranty or support. All use of this utility is at your own risk. The
code
'has been tested with PowerPoint 2000, PowerPoint 2002 and PowerPoint
2003
'(Both with/without Service Packs) where appropriate. This does not
guarantee
'that they will work on your machine.

'Licensing Policy:
'This code is provided as FREEWARE. You may use and adapt this utility
for
'your own individual projects. It is NOT distributable. You CANNOT
bundle it
'with other individual /commercial applications without the prior
consent of
'the author. You may not include this utility in any shareware or
freeware
'catalogues, books, articles or periodicals without the written
permission of
'the author.


'Hans W. Hofmann.
'h w (at) p p t - u s e r .d e




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 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 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long


Private Const SM_SCREENX = 0
Private Const SM_SCREENY = 1
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, dPoint As PointAPI
Public ActiveShape As Shape
Dim dragMode As Boolean
Dim dx As Double, dy As Double


Sub DragandDrop(sh As Shape)

 dragMode = Not dragMode
 If dragMode Then Drag sh
 
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): dPoint.x = dx
dy = GetSystemMetrics(SM_SCREENY): dPoint.y = dy


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: Exit Sub ' Not Aus
Wend

End Sub