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 |
Partager