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"