鼠标粘小球任意移动效果怎么做的
交互区看到的，哪位高手讲解一下怎么做的，最好具体点，（动感老师的拖拉实例）版主讲具体点，只有代码，还是不明白，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
页:
[1]