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