鼠标粘小球任意移动效果怎么做的

w12345678 发表于: 2010-10-05 01:01 来源: 扑奔PPT网

amwyq 发表于 2010-10-05 02:24:30

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 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 Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const TWIPSPERINCH = 1440
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 LoadShow()
    Dim iShapes As Shape
    Dim n As Integer
    n = 0
    With SlideShowWindows(1)
        .View.GotoSlide (.Presentation.Slides(2).SlideIndex)
    End With
   
    With ActivePresentation.Slides(2)
        For Each iShapes In .Shapes
            n = n + 1
            iShapes.Name = "Shape" & n
            iShapes.ActionSettings(ppMouseClick).Action = ppActionRunMacro
            iShapes.ActionSettings(ppMouseClick).Run = "MoveShape"
        Next
    End With
End Sub

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