Macro pour lien hypertexte et pour masquer diapositive

Invité · 20/01/2017, 22h35

Bonsoir le forum

on viens de me donner un ppt pour afficher les numéros d un loto sur grand écran
ce ppt contient des macros

sur la diapo n°1 il y a les 90 boules Quand on clic sur le contour d'un numéro ce numéro disparait pour apparaitre en grand sur la diapos n°2 et a sa taille de départ sur la diapo N° 3

pour faire apparaitre la diapo n°2 il faut se servir de la molette de la souris ou les flèches qui se trouve en bas a gauche

la diapo n°3 apparait au bout de 7 secondes

pour revenir sur la diapo n°1

Sur la diapo n°1 en haut en gauche trois carres
Le Z sert a remettre toute les boules sur la diapo N°1 ( remise a zéro)
Le A est un lien hypertexte qui ouvre la diapo n° 4
Le R est un lien hypertexte qui ouvre la diapo n° 5

Les diapos n°4 et 5 sont des diapos masquer qui apparaissent que si on clic sur A et r

sur les diapos n°4 et 5 il y a un carre avec 1 qui est un lien hypertexte pour revenir sur la diapo n°1

donc j ai trois questions a vous poser pour résoudre mes problèmes

1) Comment programmer la macro pour un lien hypertexte qui fait apparaitre la diapo n°2 quand on clic sur chaque numéro de la diapo n°1

2) comment programmer un lien hypertexte sur la diapo numéro trois pour revenir a la diapo n°1 sans que ce lien hypertexte disparaisse quand on fait une remise a zéro

3) comment programmer une macro qui sert de lien hypertexte pour revenir a la diapo n°1 et qui masque les diapo n°4 et 5 car une fois que je me sert des lien hypertexte A et R de la diapo n°1

les diapos n°4 et 5 apparaisse avec la molette si on fait défiler les diapos dans le sens 3 2 1

je vous joint mon fichier

http://www.cjoint.com/c/GAuvGQJ2Dj5

merci d'avance pour votre aide

cordialement

Snoopy 07

Invité · 21/01/2017, 10h53

bonjour le forum

je viens de voir que le lien pour le fichier de marche pas

je n arrive a mettre le fichier sur le site

alors je vous met la macro et des photos des diapos

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
Sub Auto_Open()
    Init_All
End Sub
 
Sub Init_All()
    ' Show all balls
    ' ---------------------------
    Dim iBingoSlides As Integer
    Dim iBingoShapes  As Integer
    Dim bBallsAreVisible As Boolean
 
    On Error Resume Next
 
    If MsgBox("Voulez-vous remettre à zéro l'ensemble des boules ?", vbOKCancel, "Redémarrage Loto") = vbOK Then
        bBallsAreVisible = True
 
        ' All slides : All balls visible
        For iBingoSlides = 1 To ActivePresentation.Slides.Count
            For iBingoShapes = 1 To ActivePresentation.Slides(iBingoSlides).Shapes.Count
                ActivePresentation.Slides(iBingoSlides).Shapes(iBingoShapes).Visible = bBallsAreVisible
            Next iBingoShapes
        Next iBingoSlides
 
        ' Slide 02 : Clear Number and Dummy
        ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").TextFrame.TextRange.Text = "-"
        ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Delete
 
        ' Slide 03 : Hide balls
        For iBingoShapes = 1 To ActivePresentation.Slides("Slide_After").Shapes.Count
            ActivePresentation.Slides("Slide_After").Shapes(iBingoShapes).Visible = msoFalse
            'ActivePresentation.Slides("Slide_After").Shapes(iBingoShapes).Visible = msoTrue
        Next iBingoShapes
        ' Slide 03 : make the title visible
        ActivePresentation.Slides("Slide_After").Shapes("TitleBallsSorted").Visible = msoTrue
        ActivePresentation.Slides("Slide_After").Shapes("BoxNumber").Visible = msoTrue
    End If
End Sub
 
Sub Auto_NextSlide(Index As Long)
'    If ActivePresentation.SlideShowWindow.View.Slide.SlideIndex = 1 Then
'        ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").TextFrame.TextRange.Text = " "
'    End If
End Sub
 
Sub Init_Balls_Before()
    Dim iBingoShapes  As Integer
    Dim sBingoShapes As String
    Dim iHorizontalOffset As Integer
    Dim bBallsAreVisible As Boolean
 
    On Error Resume Next
 
    iHorizontalOffset = 50
    ' Slide 01 : Duplicate balls
    DuplicateBallHorizontally "Slide_Before", 1, 10, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 11, 20, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 21, 30, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 31, 40, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 41, 50, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 51, 60, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 61, 70, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 71, 80, iHorizontalOffset
    DuplicateBallHorizontally "Slide_Before", 81, 90, iHorizontalOffset
    'DuplicateBallHorizontally 20, 29, iHorizontalOffset
 
    ' Slide 03 : Duplicate balls
    'DuplicateBallHorizontally "Slide_After", 10, 19, iHorizontalOffset
 
End Sub
 
Sub BallClick(oShapeBall As Shape)
    Dim iCurrentSlide As Integer
    Dim iOppositeSlide As Integer
    Dim iVerticalOffset As Integer
    iVerticalOffset = 20
 
    ' Save the current Ball and Number names
    ActivePresentation.Tags.Add "SelectedBall", oShapeBall.Name
    ActivePresentation.Tags.Add "SelectedNumber", Replace(oShapeBall.Name, "b", "n")
 
    ' Define the target slide number
    If ActivePresentation.SlideShowWindow.View.Slide.SlideIndex = 1 Then
        iCurrentSlide = 1
        iOppositeSlide = 3
 
        ' Slide 02 : Display number
        ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").TextFrame.TextRange.Text = Replace(ActivePresentation.Tags("SelectedNumber"), "n", "")
 
        ' Slide 01 : Copy the ball picture from 1st slide to 2nd one
        On Error Resume Next
        ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Delete
        On Error GoTo 0
 
        ActivePresentation.Slides("Slide_Before").Shapes(oShapeBall.Name).Copy
        ActivePresentation.Slides("Slide_Zoom").Shapes.Paste
        ActivePresentation.Slides("Slide_Zoom").Shapes(oShapeBall.Name).Name = "dummy"
        ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Visible = msoCTrue
 
        ' Slide 02 : Center the ball
        ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Left = (ActivePresentation.PageSetup.SlideWidth - ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Width) / 2
        ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Top = (ActivePresentation.PageSetup.SlideHeight - ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Height) / 2
        ' Slide 02 : Scale the ball
        ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").ScaleHeight 0.6, msoTrue, msoScaleFromMiddle
        ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").ScaleWidth 0.6, msoTrue, msoScaleFromMiddle
        ' Slide 02 : Center textbox with ball's number
        ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Left = (ActivePresentation.PageSetup.SlideWidth - ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Width) / 2
        ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Top = ((ActivePresentation.PageSetup.SlideHeight - ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Height) / 2) - iVerticalOffset
        ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").ZOrder msoBringToFront
    Else
        iCurrentSlide = 3
        iOppositeSlide = 1
    End If
 
    ' This ball is visible
    If oShapeBall.Visible Then
        ' We make it NOT visible on the opposite slide
        ActivePresentation.Slides(iCurrentSlide).Shapes(ActivePresentation.Tags("SelectedBall")).Visible = msoFalse
        ActivePresentation.Slides(iCurrentSlide).Shapes(ActivePresentation.Tags("SelectedNumber")).Visible = msoFalse
        ActivePresentation.Slides(iOppositeSlide).Shapes(ActivePresentation.Tags("SelectedBall")).Visible = msoTrue
        ActivePresentation.Slides(iOppositeSlide).Shapes(ActivePresentation.Tags("SelectedNumber")).Visible = msoTrue
 
    Else
        ' We make it visible on the opposite slide
        ActivePresentation.Slides(iCurrentSlide).Shapes(ActivePresentation.Tags("SelectedBall")).Visible = msoTrue
        ActivePresentation.Slides(iCurrentSlide).Shapes(ActivePresentation.Tags("SelectedNumber")).Visible = msoTrue
        ActivePresentation.Slides(iOppositeSlide).Shapes(ActivePresentation.Tags("SelectedBall")).Visible = msoFalse
        ActivePresentation.Slides(iOppositeSlide).Shapes(ActivePresentation.Tags("SelectedNumber")).Visible = msoFalse
    End If
 
 
End Sub
 
Sub GrabBall(oShapeBall As Shape)
    Dim oEffect As Effect
    Dim oShapeNumber As Shape
    Dim iVerticalOffset As Integer
    iVerticalOffset = 20
 
    ' Save the ball name
    ActivePresentation.Tags.Add "SelectedBall", oShapeBall.Name
    ' Save the ball number
    ActivePresentation.Tags.Add "SelectedNumber", Replace(oShapeBall.Name, "b", "n")
 
    ' Slide 01 : Hide the target ball
    oShapeBall.Visible = msoFalse
    ActivePresentation.Slides("Slide_Before").Shapes(ActivePresentation.Tags("SelectedNumber")).Visible = msoFalse
 
    ' Slide 02 : Display number
    ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").TextFrame.TextRange.Text = Replace(ActivePresentation.Tags("SelectedBall"), "b", "")
 
    ' Slide 01 : Copy the ball picture from 1st slide to 2nd one
    ActivePresentation.Slides("Slide_Before").Shapes(oShapeBall.Name).Copy
    ActivePresentation.Slides("Slide_Zoom").Shapes.Paste
    ActivePresentation.Slides("Slide_Zoom").Shapes(oShapeBall.Name).Name = "dummy"
    ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Visible = msoCTrue
 
    ' Slide 02 : Center the ball
    ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Left = (ActivePresentation.PageSetup.SlideWidth - ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Width) / 2
    ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Top = (ActivePresentation.PageSetup.SlideHeight - ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").Height) / 2
    ' Slide 02 : Scale the ball
    ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").ScaleHeight 0.7, msoTrue, msoScaleFromMiddle
    ActivePresentation.Slides("Slide_Zoom").Shapes("dummy").ScaleWidth 0.7, msoTrue, msoScaleFromMiddle
    ' Slide 02 : Center textbox with ball's number
    ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Left = (ActivePresentation.PageSetup.SlideWidth - ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Width) / 2
    ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Top = ((ActivePresentation.PageSetup.SlideHeight - ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").Height) / 2) - iVerticalOffset
    ActivePresentation.Slides("Slide_Zoom").Shapes("txtBallName").ZOrder msoBringToFront
 
    ' Slide 03 : Copy the ball from the 1st slide to the last one
    ActivePresentation.Slides("Slide_Before").Shapes(ActivePresentation.Tags("SelectedBall")).Copy
    ActivePresentation.Slides("Slide_After").Shapes.Paste
    ActivePresentation.Slides("Slide_After").Shapes(ActivePresentation.Tags("SelectedBall")).Visible = msoTrue
    ActivePresentation.Slides("Slide_Before").Shapes(ActivePresentation.Tags("SelectedNumber")).Copy
    ActivePresentation.Slides("Slide_After").Shapes.Paste
    ActivePresentation.Slides("Slide_After").Shapes(ActivePresentation.Tags("SelectedNumber")).Visible = msoTrue
 
    ' Go to next slide
    SlideShowWindows(1).View.GotoSlide 2, msoFalse
End Sub
 
 
Sub RenameElement()
    Dim Name$, NameSlide$
    On Error GoTo AbortNameShape
 
    If ActiveWindow.Selection.ShapeRange.Count = 0 Then
    MsgBox "No Shapes Selected"
    Exit Sub
    End If
    Name$ = ActiveWindow.Selection.ShapeRange(1).Name
    NameSlide$ = ActiveWindow.Selection.SlideRange.Name
 
    Name$ = InputBox$("Give this shape a name", "Shape Name", Name$)
    NameSlide$ = InputBox$("Give this slide a name", "Slide Name", NameSlide$)
 
    If Name$ <> "" Then
    ActiveWindow.Selection.ShapeRange(1).Name = Name$
    End If
 
    If NameSlide$ <> "" Then
    ActiveWindow.Selection.SlideRange.Name = NameSlide$
    End If
 
 
    Exit Sub
 
AbortNameShape:
    MsgBox Err.Description
 
End Sub
 
Sub DuplicateBallHorizontally(sSlideName As String, iFrom As Integer, iTo As Integer, iOffset As Integer)
    Dim iBingoShapes As Integer
 
    For iBingoShapes = iFrom To iTo - 1
        ' Duplicate balls horizontaly
        sBingoShapes = "b" & iBingoShapes
        With ActivePresentation.Slides(sSlideName).Shapes(sBingoShapes).Duplicate
            .IncrementLeft iOffset
            .Top = ActivePresentation.Slides(sSlideName).Shapes("b" & iFrom).Top
            .Name = "b" & (iBingoShapes + 1)
        End With
        ' Affect action to the ball
        With ActivePresentation.Slides(sSlideName) _
            .Shapes(sBingoShapes).ActionSettings(ppMouseClick)
                .Action = ppActionRunMacro
                .Run = "BallClick" '"GrabBall"
                .AnimateAction = msoFalse
        End With
        ' Duplicate the textbox number
        sBingoShapes = "n" & iBingoShapes
        With ActivePresentation.Slides(sSlideName).Shapes(sBingoShapes).Duplicate
            .IncrementLeft iOffset
            .Top = ActivePresentation.Slides(sSlideName).Shapes("n" & iFrom).Top
            .Name = "n" & (iBingoShapes + 1)
            .TextFrame.TextRange.Text = iBingoShapes + 1
        End With
    Next iBingoShapes
End Sub

La diapo n°1
Pièce jointe 237043

La diapo n°2Pièce jointe 237052

La diapo n°3
Pièce jointe 237053

La diapo n°4
Pièce jointe 237058

La diapo n°5
Pièce jointe 237067

En esperant que ca puisse vous aidez

Cordialement
Snoopy 07

Invité · 22/01/2017, 00h52

bonsoir le forum

une derniere question est ce qu il y a une personne qui peut m 'aider sur ce forum car pour le moment plusieurs personne a regarder mon post mais personne ma dit quelque chose

si personne peut m 'aider sur ce forum j irais poser ma question sur un autre forum

et je fermerai mon profil car c est inutile que je reste sur ce forum si personne peut m aider

cordialement

Snoopy 07

**clementmarcotte** · 22/01/2017, 23h35

C'est la fin de semaine, et ceux qui répondent le font bénévolement, à travers leurs autres obligations. Tu veux un code gratuit, clef-en-main et tu le veux pour hier.

Premièrement, cela peut se faire sans lien hypertexte.
Deuxièmement, tu peux insérer des boutons ActiveX sur une diapositive et leur assigner une macro

Troisièmement, pour sélectionner une diapositive par VBA en cours de présentation tu prends

gotoslide

Quatrièmement, PowerPoint 2010 a des fichiers d'aide locale pour PowerPoint et pour VBA.

Cinquièmement, les ultimatums sont généralement de nature à faire éviter de répondre, pour ne pas devenir esclaves.

Quand à moi, ce sera moi, ce sera mon unique réponse sur ce sujet. Peut-être que d'autres accepteront de continuer, ce sera leur décision.

Invité · 23/01/2017, 08h13

bonjour clementmarcotte

merci pour ta réponse

quand je vois que cinquante personne ont regarder la discussion et que personne te dit oui c 'est possible ou non on peut rien faire cela énerve un peu
je sais bien que ce qui réponde le font bénévolement et je leur tire mon chapeau

cordialement
Snoopy 07

Macro pour lien hypertexte et pour masquer diapositive [PPT-2010]

VBA PowerPoint

Discussions similaires

Partager

Partager