Discussion :

[Gorzyne]

Bonjour,

Je réalise un outil pour générer un rapport sous powerpoint de Excel vers Powerpoint, des strings, tableaux et graphiques
Je réalise l'outil ça fonctionne j'envoie à mon interlocuteur qui me dit ça bugue

Je me connecte à distance et là je vois la petite pomme croquée, interloqué (on est en finance) je m'exclame spontanément "mais vous êtes sous Mac ! "
Il me fait "oui d'ailleurs je comprends pas qu'il y ait encore des gens sous Windows"

J'ai manqué de lui dire que la portabilité est pas ouf, surtout quand on est sur des API tierces... j'ai déjà eu des soucis à ce sujet en milieu associatif, mais la pour un financier ça m'étonne quand même

Gentil je lui dit que je vais trouver une solution (à l'oeil) donc pour les tableaux j'arrive à trouver un truc qui passe

en gros j'emploie la méthode .CopyPicture au lieu d'un .Copy et ça passe avec un Maslide.Shapes.Paste tout bête
par contre pour le graphique ça ne passe pas, le presse papier semble bon quand je vais manuellement sous PPT je peux faire mon pomme-V il copie, et même depuis la fenêtre execution il parvient à copier une fois que j'ai donné le focus à PPT

dans mon code j'ai mis un pptApp.activate pour essayer de donner la main à PPT avec un petit doevents en prime
du coup je suis bloqué à ce stade, je perds un temps fou pour rien (j'avais prévu de faire le ménage)

merci pour vos retours
Gorz

[Gorzyne]

je me réponds à moi même pour celles et ceux que ça peut aider
la solution trouvée a consisté à mettre un timer
au début j'avais mis une seconde mais ce n'était pas suffisant
j'ai fait des tests à 5sec puis à 3 apparemment ça passe mais à 1 parfois ça passe parfois pas
ce qui est surprenant c'est que le timer est nécessaire que pour les graphiques (ChartObjects) mais les tableaux (Range) pas besoin... allez comprendre
voilà voilou

[Gorzyne]

bon je suis toujours pas plus avancé
la temporisation a permis sur certains mac de résoudre mais pas sur tous
à un moment il y a eu un droit d'accès demandé; en mode débug fenêtre d'execution, ce qui a pu résoudre temporairement le pb
mais il y a une question de reproductibilité du bug... bref je suis un peu perdu
j'ai l'impression que le bins tourne autour de la gestio du presse papier mais je comprends pas pourquoi ça marche pour les range et pas les charts

[Gorzyne]

Je pose le code spécifié, le bug a lieu dans la dernière macro RemplacerMarqueurspartableau à l'instruction pptSlide.Shapes.Paste
selon les macs parfois ça passe parfois pas, en général j'ai une erreur clipboard contains data that can't be pasted ou un truc du genre après un délai d'attente long
err.num renvoie toujours 0 par contre targetshape is nothing
j'ai essayé en lançant du code vba côté ppt, ça renvoie la même erreur
je continue à creuser mais si quelqu'un de chaud en vba à la solude c'est top

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
 
Public pptApp As Object
Public pptPresentation As Object
Sub getap()
 
 
    '------------------   INITIALISATION  -------------------
    Set wspilot = ThisWorkbook.Sheets("Transco") 'ThisWorkbook.targetws
    wspilot.Range("Etat_prog").Interior.Color = RGB(255, 214, 153)
    wspilot.Range("Etat_prog").Value = "Exportation en cours"
    Application.Wait (Now + TimeValue("0:00:01"))
    DoEvents
    Application.ScreenUpdating = False
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    '----------   GESTION ERREUR PRESENTATION  -------
    If pptApp Is Nothing Then
        wspilot.Range("Etat_prog") = "Ouvrir PowerPoint"
        Application.ScreenUpdating = True
        MsgBox "PowerPoint n'est pas ouvert"
        Exit Sub
    End If
 
    Dim wbcible As Workbook
    On Error Resume Next
    Set wbcible = Workbooks(wspilot.Range("classeur3TP").Value)
    On Error GoTo 0
    '----------   GESTION ERREUR CLASSEUR SOURCE -------
    If wbcible Is Nothing Then
        wspilot.Range("Etat_prog") = "Classeur source non trouve"
        wspilot.Range("Etat_prog").Interior.Color = RGB(219, 179, 217)
 
        Application.ScreenUpdating = True
        MsgBox "Le classeur source ne semble pas ouvert"
        Exit Sub
    End If
 
    Set pptPresentation = pptApp.ActivePresentation
 
    '!!!!!!!!!!!!!!!!!!!!!!!    DEBUT BOUCLE BALISE   !!!!!!!!!!!!!!!!!!!!!!!
    numbalise = 1
    While wspilot.Range("Balise").Offset(numbalise, 0) <> "" 'ici on boucle sur les balises
 
        wspilot.Range("etatexport").Offset(numbalise, 0) = ""
        If wspilot.Range("export").Offset(numbalise, 0) = 1 Then 'on v_rifie si l'utilisateur a demande l'exportation de la donnee
 
            '------------------   GESTION CLASSEUR SOURCE  ------------------
            If wspilot.Range("sourcebis").Offset(numbalise, 0).Value <> "" Then
                Set sourcecible = Nothing
                On Error Resume Next
                Set sourcecible = Workbooks(wspilot.Range("sourcebis").Offset(numbalise, 0).Value)
                On Error GoTo 0
                '----------   GESTION ERREUR SOURCE SECONDAIRE  -------
                If sourcecible Is Nothing Then
                    wspilot.Range("Etat_prog") = "Classeur secondaire non trouve"
                    wspilot.Range("Etat_prog").Interior.Color = RGB(219, 179, 217)
                    Application.ScreenUpdating = True
                    wspilot.Range("sourcebis").Offset(numbalise, 0).Select
                    MsgBox "Le classeur " & wspilot.Range("sourcebis").Offset(numbalise, 0).Value & " ne semble pas ouvert"
                    Exit Sub
                End If
            Else
                Set sourcecible = wbcible
            End If
 
            manature = wspilot.Range("Nature").Offset(numbalise, 0).Value
            mononglet = wspilot.Range("Onglet").Offset(numbalise, 0).Value
            monpointeur = wspilot.Range("Pointeur").Offset(numbalise, 0).Value
            monpointeur2 = wspilot.Range("Pointeur").Offset(numbalise, 1).Value
 
 
            monetat = wspilot.Range("Etat").Offset(numbalise, 0)
            If manature = "Chaine de caractere" Then
                Call RemplacerMarqueurs(wspilot.Range("Balise").Offset(numbalise, 0), wspilot.Range("valformat").Offset(numbalise, 0), wspilot.Range("etatexport").Offset(numbalise, 0), wspilot.Range("remplacetous").Offset(numbalise, 0))
            Else
                sourcecible.Activate
                sourcecible.Sheets(mononglet).Select
                lebonpointeur = ""
                If monetat = "Le pointeur principal a ete trouve" Then
                    lebonpointeur = monpointeur
                ElseIf monetat = "Le pointeur secondaire a ete trouve" Then
                    lebonpointeur = monpointeur2
                End If
 
                If lebonpointeur <> "" And manature = "Tableau" Then
 
                    Call RemplacerMarqueurspartableau(wspilot.Range("Balise").Offset(numbalise, 0), sourcecible.Sheets(mononglet).Range(lebonpointeur), wspilot.Range("Left").Offset(numbalise, 0), wspilot.Range("Top").Offset(numbalise, 0), wspilot.Range("height").Offset(numbalise, 0), wspilot.Range("width").Offset(numbalise, 0), wspilot.Range("deletebalise").Offset(numbalise, 0), manature, wspilot.Range("etatexport").Offset(numbalise, 0), wspilot.Range("remplacetous").Offset(numbalise, 0))
                    If wspilot.Range("export0") Then wspilot.Range("export").Offset(numbalise, 0) = 0
                ElseIf lebonpointeur <> "" And manature = "Graphique" Then
                    Call RemplacerMarqueurspartableau(wspilot.Range("Balise").Offset(numbalise, 0), sourcecible.Sheets(mononglet).ChartObjects(lebonpointeur), wspilot.Range("Left").Offset(numbalise, 0), wspilot.Range("Top").Offset(numbalise, 0), wspilot.Range("height").Offset(numbalise, 0), wspilot.Range("width").Offset(numbalise, 0), wspilot.Range("deletebalise").Offset(numbalise, 0), manature, wspilot.Range("etatexport").Offset(numbalise, 0), wspilot.Range("remplacetous").Offset(numbalise, 0))
                    If wspilot.Range("export0") Then wspilot.Range("export").Offset(numbalise, 0) = 0
                Else
                    wspilot.Range("etatexport").Offset(numbalise, 0) = "La cible n'est pas pointee correctement"
                    wspilot.Range("etatexport").Offset(numbalise, 0).Interior.Color = RGB(255, 218, 185)
                End If
                ThisWorkbook.Activate
            End If
        Else
            wspilot.Range("etatexport").Offset(numbalise, 0) = "Export desactive pour la cible"
            wspilot.Range("etatexport").Offset(numbalise, 0).Interior.Color = RGB(230, 230, 250)
 
        End If
        numbalise = numbalise + 1
    Wend
 
    pptApp.Activate
    Set pptPresentation = Nothing
    Set pptApp = Nothing
    Application.ScreenUpdating = True
    wspilot.Range("Etat_prog") = "Exportation terminee"
    Range("Etat_prog").Interior.Color = RGB(135, 206, 235)
    Debug.Print "export termine avec succes"
 
 
End Sub
Sub RemplacerMarqueurs(balise, replacementText, etatexport, remplacer) 'cette fonction remplace toutes les occurences de la balise
    Dim pptSlide As Object
    ' Remplacer les balises sur chaque diapositive
    nbexport = 0
    For Each pptSlide In pptPresentation.Slides
        For Each myshapes In pptSlide.Shapes
            trouvtext = ""
            On Error Resume Next
            trouvtext = InStr(1, myshapes.TextFrame.TextRange.Text, balise)
            On Error GoTo 0
            If Not (trouvtext = "" Or trouvtext = 0) Then
                myshapes.TextFrame.TextRange.Characters(trouvtext, Len(balise)) = replacementText
                nbexport = nbexport + 1
                If remplacer = 1 Then GoTo sortirdetoutes
            End If
        Next myshapes
    Next pptSlide
sortirdetoutes:
    If nbexport > 0 Then
        etatexport.Value = "La cible a ete exportee " & nbexport & " fois"
        etatexport.Interior.Color = 15917529
    Else
        etatexport.Value = "La balise ne semble pas avoir ete trouvee"
        etatexport.Interior.Color = RGB(255, 218, 185)
    End If
End Sub
Sub RemplacerMarqueurspartableau(balise, replacementTab, myleft, mytop, myheight, mywidth, deletebalise, manature, etatexport, remplacer) 'cette fonction ne remplace qu'une seul occurence
    Dim pptSlide As Object
    Dim targetshape As Object
    Set clipboardData = Nothing
    nbexport = 0
    For Each pptSlide In pptPresentation.Slides 'parcourir les slides
        For Each myshapes In pptSlide.Shapes 'parcourir les diff_rents shapes
            trouvtext = ""
            On Error Resume Next
            trouvtext = InStr(1, myshapes.TextFrame.TextRange.Text, balise) 'recherche de la balise
            On Error GoTo 0
            If Not (trouvtext = "" Or trouvtext = 0) Then 'test si la balise a _t_ trouv_e
 
            If manature = "Graphique" Then
                replacementTab.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
                DoEvents
                Application.Wait (Now + TimeValue("0:00:04"))
 
                Err.Clear
                On Error Resume Next
                Set targetshape = pptSlide.Shapes.Paste
                On Error GoTo 0
 
                If targetshape Is Nothing Or Err.Number <> 0 Then
                    etatexport.Value = "Erreur d'exportation"
                    etatexport.Interior.Color = RGB(250, 128, 114)
                    Err.Clear
                    GoTo sortieerreur
                End If
 
            Else
                replacementTab.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
                Set targetshape = pptSlide.Shapes.Paste
            End If
 
                With targetshape
                    .LockAspectRatio = msoTrue
                    If myleft <> "" Then .Left = myleft
                    If mytop <> "" Then .Top = mytop
                    If myheight <> "" Then .Height = myheight
                    If mywidth <> "" Then .Width = mywidth
                End With
                If deletebalise = 1 Then myshapes.Delete
                nbexport = nbexport + 1
                If remplacer = 1 Then GoTo sortirdetoutes
            End If
        Next myshapes
    Next pptSlide
sortirdetoutes:
    If nbexport > 0 Then
        etatexport.Value = "La cible a ete exportee " & nbexport & " fois"
        etatexport.Interior.Color = 15917529
    Else
        etatexport.Value = "La balise ne semble pas avoir ete trouvee"
        etatexport.Interior.Color = RGB(255, 218, 185)
    End If
sortieerreur:
End Sub