Difficulté sous mac VBA avec une instruction .Paste sous Mac
n
Bonjour,
J'ai un souci avec une automation Excel vers Powerpoint au moment de coller un graphique dans une présentation.
Le programme fonctionne sans souci pour les objets range, et de toute façon j'opte pour un .CopyPicture donc je suis étonné que le type de source génère un comportement différent, je pensais que .CopyPicture aller charger un objet du même type dans le presse papier, mais force est de constater que sur certaines plateforme mac (pas toutes) le code ne fonctionne pas
Mon erreur se trouve dans la macro
RemplacerMarqueurspartableauà l'instruction
Set Targetshape = pptSlide.Shapes.PasteL'erreur typique est que l'on ne peut copier car le presse papier contient des données invalides, cette erreur intervient après un temps d'attente relativement long, et Err.num = 0 donc je vois juste que targetshape is nothing
J'ai essayé différentes variantes, par exemple pptSlide.Commandbars.ExecuteMSO "Paste" ce qui fonctionne ou pas selon les plateformes mais continue donc de buguer. Egalement de copier une première fois en image le graphique internement à Excel pour ensuite copier l'image vers PPT ... mais je patauge encore
Voici l'intégralité du code de la routine
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 'erreur à cette instruction
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 SubBonjour Nianiana,
J'ai un souci avec une automation Excel vers Powerpoint au moment de coller un graphique dans une présentation.
Pour pallier à ce souci, il serait préférable auparavant de faire une copie du graphique sur le disque. Par exemple dans le répertoire Images.
Cette partie de ton code ci-dessous
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 'erreur à cette instructionsera remplacée par
If manature = "Graphique" Then
replacementTab.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
'puis appel à la macro de sauvegarde du graphique sur disque
KopImg
DoEvents
Application.Wait (Now + TimeValue("0:00:04"))
'Ou le slide de réception est ici le premier slide mais sera dans ton cas un slide à préciser. Selon ta boucle des slides.
Set myDocument = pptPresentation.Slides(1)
'Reprise du graphique sauvegardé sous le nom choisi. Les Positions, largeur et hauteur sont selon préférences
myDocument.Shapes.AddPicture Filename:="C:\Users\Untel\Pictures\TabloNew.jpg", LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=100, Top:=100, Width:=200, Height:=200Le code ci-dessous de la macro KopImg
Sub KopImg()
Dim MyChart As Chart, NomImage As String
'Récupération du texte d'une cellule ou nom à prédéfinir pour l'image
NomImage = "TabloNew"
'Copier l'image selon nom souhaité avec mensurations
ActiveSheet.Paste: Selection.Name = NomImage
Haut = ActiveSheet.Shapes(NomImage).Height
Large = ActiveSheet.Shapes(NomImage).Width
'Copie sur l'ordinateur à adapter selon le dossier personnel avec nom de l'image
'Application.UserName
Chemin = "C:\Users\Untel" & "\Pictures\" & NomImage & ".jpg"
With ActiveSheet
Set MyChart = .ChartObjects.Add(0, 0, Large, Haut).Chart
'Réalise l'export avec l'objet Chart puis supprime ce dernier
With MyChart
.Parent.Activate
.ChartArea.Format.Line.Visible = msoFalse 'Ligne du cadre non visible
.Paste
.Export Filename:=Chemin
.Parent.Delete
End With
End With
Set MyChart = Nothing
ActiveSheet.Shapes(NomImage).Delete
Range("A20").Select 'Ou tout autre cellule
End SubLe graphique sauvegardé peut aussi être détruit ensuite s'il n' a pas vocation à être conservé.
n
salut merci effectivement il y a une solution de ce type qu'il m'est déjà arrivé de mettre en oeuvre pour pouvoir afficher un graphique dans une usf
ça m'embête un peu d'en arriver là mais si tu penses que ça résolvera le problème (qui n'a pas l'air de te surprendre)
j'imagine qu'on peut utiliser thisworkbook.path pour le chemin, attention on est sous mac donc C: est plutôt du chemin windows
n
petit update
j'ai testé la solution mais j'ai une erreur 70 l'écriture n'est pas autorisée sur le système Mac ce qui n'est pas très étonnant vu qu'il fonctionne en bac à sable
au passage c'est peut être de là d'où provient l'erreur initialement ?