Consulting

Results 1 to 8 of 8

Thread: Need help on mac vba for XL-> PPT automation

  1. #1
    VBAX Newbie
    Joined
    Sep 2023
    Posts
    4
    Location

    Need help on mac vba for XL-> PPT automation

    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

  2. #2
    Moderator VBAX Wizard Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    5,232
    Location
    Welcome to VBAX toto41. Hopefully someone will be along shortly to interpret your code.
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  3. #3
    Administrator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,254
    Location
    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.
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved
    Click here for a guide on how to upload a file with your post

    Excel 365, Version 2408, Build 17928.20080

  4. #4
    VBAX Newbie
    Joined
    Sep 2023
    Posts
    4
    Location
    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

  5. #5
    VBAX Newbie
    Joined
    Sep 2023
    Posts
    4
    Location
    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

  6. #6
    Moderator VBAX Wizard Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    5,232
    Location
    vba error 70 is a "Permission denied" error.
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  7. #7
    VBAX Newbie
    Joined
    Sep 2023
    Posts
    4
    Location
    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"

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •