Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Visual Basic » Problemas con arrastrables en Power Point

Visual Basic - Problemas con arrastrables en Power Point

Life is soft - evento anual de software empresarial
Volver
Nuevo Tema
<<>>
 
Vista:
sin imagen de perfil
Val: 2
Ha aumentado 1 puesto en Visual Basic (en relación al último mes)
Gráfica de Visual Basic

Problemas con arrastrables en Power Point

Publicado por Francisco (1 intervención) el 27/03/2021 10:04:04
Hola a tod@s

Estoy intentando crear objetos arrastrables en Power Point para poder emplearlos en el aula, pero no lo consigo. Cuando ejecutó el modo presentación no me deja de arrastrar el elemento


He creado dos módulos:
- MoveShapeModule
- HostClass

Los códigos que estoy aplicando a cada uno de los módulos son los siguientes:

Para MoveShapeModule

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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
 
Para HostClass
 
ption Explicit
 
Private WithEvents HostApp As PowerPoint.Application
 
Private Sub Class_Initialize()
    Set HostApp = PowerPoint.Application
End Sub
 
Private Sub HostApp_SlideShowEnd(ByVal Pres As Presentation)
    MoveShapeModule.EndMoveShape
End Sub


Muchas gracias
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder