Need help on mac vba for XL-> PPT automation

[toto41]

Hi all

I have an issue with a .Paste instruction that will regularly launch an error on some Mac platforms.


The subroutine where the error occur is

RemplacerMarqueurspartableau

The instruction that strikes an error is

Set Targetshape = pptSlide.Shapes.Paste

After a long time, typical error is that clipboard contains unappropriate data

I have tried several variations (CommandBars.ExecuteMSO "Paste" for example) but with no stable success (program will run fine sometimes on some MAC systems but not on the target system)
What is noticable is that code will function correctly for all range objects and wil only bug for graphics...


Thanks for any help !!

Full code follows


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

[Aussiebear]

Welcome to VBAX toto41. Hopefully someone will be along shortly to interpret your code.

[georgiboy]

Maybe it is taking a while for the graphic to land in the clipboard:

Try:
Before the below line:

replacementTab.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Add the line:

Application.CutCopyMode = False
This will empty the clipboard before you copy the graphic and will empty the clipboard of data that is not suitable.

---

Then, instead of this line:

Set Targetshape = pptSlide.Shapes.Paste
Try:

Do
On Error Resume Next
Set Targetshape = pptSlide.Shapes.Paste
If Err.Number = 0 Then Exit Do
DoEvents
Loop
On Error GoTo 0

This will keep trying said line until it does not produce an error.

[toto41]

Thanks for the ideas
what is strange is that the error is kinda external, and Err.num =0

this is why I test


If targetshape Is Nothing Or Err.Number <> 0 Then

and not just Err.num because in fact what triggers the test is that targetshape is nothing
In some cases you can have an error and Err.num=0

I had a look at the error code and it went a bit far for my understanding, error code didn't seem to be specificaly related to my problem but more like a wider error, and I also tried to call the .paste instruction from the ppt vba side and had exactly the same error

someone suggested me to save graphic as an image first in the desired folder, then paste it back in ppt, but I have issues of writing access error (70), Mac working as a sandbox this type of error wasn't a big surprise, maybe global problem is rooted at this access issue, I recall at one stage I was "sometimes" asked by the system to grant access then the .paste instruction would run smoothly and the program end properly... couldn't be repeated for sure

[toto41]

I realized that the target computer has MAlwarebytes installed on it
could this be a reason why graphics won't paste in any method
I tried also to .export the graph to a folder and encounter an err 70 writing access issue

[Aussiebear]

vba error 70 is a "Permission denied" error.

[toto41]

yes I know; so could the antivirus be involved ?
couldn't the creation of a new file from an unidentified program be seen as suspicious by Malwarebytes
Indeed the program tends to freeze and sends an error after a long period of time, which is unusual since vba error are usually quite immediate and by the way, Err.num = 0 so it'es like the error seems "external"

[welshexpect]

I found that Malwarebytes is installed on the target machine; perhaps this explains why images won't paste using any method?