Macro instable Copier/Coller

Anthonymctm

XLDnaute Occasionnel
Bonjour à tous,

Après un dur labeur et grâce à votre aide je suis parvenu a faire une macro qui export mes données excel sous Word, j'ai récemment opté pour un copier coller en tant qu'image :
VB:
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.paste

Pour remplacer l'ancien :
Code:
.copy
.PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
Placement:=wdInLine, DisplayAsIcon:=False

La macro s'exécute beaucoup plus rapidement, je n'ai plus les bugs liés aux liaisons et c'est bien plus facile de gérer des images. :cool:

En revanche la macro semble instable. Parfois elle fonctionne, parfois non. Je dirais que sur 10 exécutions, 6 fonctionnent.
Ça à l'air aléatoire, sans que je ne change rien au fichier (ou que je clique ailleurs) o_O

Quand ça ne fonctionne pas c'est tantôt la ligne du .CopyPicture Appearance:=xlScreen, Format:=xlPicture qui est surlignée et parfois la ligne du .Paste

Vous trouverez un fichier exemple joint qui reproduit le même phénomène ainsi que le code en question ci dessous :
VB:
Function exist(feuille As String, nom As String) As Boolean
exist = False
On Error Resume Next
    x = Sheets(feuille).Range(nom).Address
    If Err.Number = 0 Then exist = True
On Error GoTo 0
End Function

Sub export_excel_to_word()
    Dim obj As Object
    Dim newObj As Object
    Dim sh As Worksheet
    Dim myFile
Application.ScreenUpdating = False


    Set obj = CreateObject("Word.Application")
    obj.Visible = True
    Set newObj = obj.Documents.Add
' obj.Selection.ParagraphFormat.LeftIndent = (20)
      With obj.Selection.PageSetup
        .TopMargin = (20)
        .LeftMargin = (17.5)
        .RightMargin = (20)
        .BottomMargin = (0)
        .HeaderDistance = (0)
        .FooterDistance = (15)
    End With
    
For n = 1 To 3
    If exist("En_tête", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
        .Paste
       ' .PasteSpecial Link:=True, DataType:=wdPasteBitmap, _
      'Placement:=wdInLine, DisplayAsIcon:=False
     '   .PasteSpecial Link:=True, DataType:=wdPasteEnhancedMetafile, _
      '  Placement:=wdInLine, DisplayAsIcon:=False
        .InsertBreak Type:=6
        End With
     End If
Next

For n = 1 To 15
    If exist("Descriptif", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Descriptif").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
        .Paste
        .InsertBreak Type:=6
        End With
    End If
Next

For n = 1 To 5
    If exist("Carac_tech", "page_" & Format(n, "00")) Then
     ThisWorkbook.Worksheets("Carac_tech").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With obj.Selection
        .Paste
        .InsertBreak Type:=6
        End With
    End If
Next
  
newObj.Sections(1).Footers(1).PageNumbers.Add (2)

    'obj.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add _
      ' PageNumberAlignment:=wdAlignPageNumberRight
                  
   Application.CutCopyMode = False
    myFile = Replace(ActiveWorkbook.Name, "xlsm", "docx")   'remplacer "docx" par l'extension qui convient, si nécessaire
    newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & myFile
Application.ScreenUpdating = True
    MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"

    obj.Activate
    Set obj = Nothing
    Set newObj = Nothing
End Sub
 

Pièces jointes

  • Test XL-WD (1).xlsm
    845.9 KB · Affichages: 15
Dernière édition:
Solution
Bonsoir,

Je pense qu'il faut être sûr que l'instruction Paste s'exécute donc :

- en début de la macro export_excel_to_word mettre l'instruction On Error Resume Next

- remplacer le bloc With/End With par :
VB:
        With obj.Selection
            nn = newObj.InlineShapes.Count + 1
            While newObj.InlineShapes.Count < nn: DoEvents: .Paste: Wend 'en attente de l'exécution
            .InsertBreak Type:=6
        End With
qui compte les Shapes dans Word.

Fichier joint.

A+

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Anthonymctm,
J'ai testé votre fichier sur XL2019 sans problème une dizaine de fois, et sur XL2007 idem. J'ai eu une erreur la première fois sur CopyPicture.
Mis non reproductible depuis.
J'ai rajouté option explicit et dimmensionné x et n. Mais ça ne change rien, plus d'erreur.
Ce searait sympa d'avoir d'autre avis sur d'autre XL ( 2010, 2013) pour voir.
Si vous avez 6 erreurs sur 10 et moi 0, peut être est ce dû au contexte, version XL, nb fichiers ouverts.... dans mon cas aucune appli ne tournait excepté XL et Word uniquement quand il est appelé.
 

Anthonymctm

XLDnaute Occasionnel
Bonjour Sylvanu,

Merci pour ton retour.
Je suis sous Excel 2019 par office 365.

Je me demande si ce serait pas un question de vitesse de traitement.
Souvent j'ai comme message d'erreur que le .paste essaye de coller un presse papier vide.
Comme si l'exécution de la macro allait plus vite que le fonctionnement du presse papier.

Idem dans l'autre cas ça me met une erreur au .copyPicture en me disant que rien n'est sélectionné.
Comme si ici aussi la macro essaie de copier avant d'avoir sélectionné.

Je me demande s'il faudrait pas que je rajoute du délai, quand penses-tu ?
(C'est peut-être idiot, j'y connais rien ^^')
 

Anthonymctm

XLDnaute Occasionnel
Première tentative : Erreur d'exécution '4605' méthode ou propriété n'est pas disponible car le presse-papiers est vide ou non valide
Surligné : .paste pour l'onglet carac_tech

Deuxième à quatirème : Succés

Cinquième : Erreur '4198' la commande a échoué
Surligné : idem : .paste pour l'onglet carac_tech

Sixième : Succés

Septième : Erreur d'exécution '1004' : La méthode CopyPicture de la classe Range a échoué
Surligné : ThisWorkbook.Worksheets("En_tête").Range("page_" & Format(n, "00")).CopyPicture Appearance:=xlScreen, Format:=xlPicture de l'onglet en_tête

Huitième : Idem Erreur d'exécution '1004' : La méthode CopyPicture de la classe Range a échoué
Surligné : ThisWorkbook.Worksheets("CGV").Range("CGV").CopyPicture Appearance:=xlScreen, Format:=xlPicture du dernier onglet
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Vous pouvez mettre un petit délai pour tester.
VB:
'Déclaration en tête
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) ' système 64 bits
ou
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds as Long) ' système 32 bits'

' Puis simplement'
Sleep 10  ' Le temps est exprimé en ms'
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Une idée de Samimi, on peut aussi vérifier si le presse papier est vide :
 

patricktoulon

XLDnaute Barbatruc
bonsoir le fil
sylvanu non isclipboardempty n'est pas l’idéal dans le cas d'une attente d'un bitmap ou metafile
car quand tu fait un copypicture imagine le clip comme un verre qui se rempli au fur et a mesure
donc meme si le clip n'a pasdigéré le bitmap il n'est deja plus vide

comme je l'ai indiqué plusieurs fois dans ce forum et ailleurs l'api isclipboardformatavailable avec argument "2" pour bitmap ou 14 pour metafile dans un do/loop
est la seule qui te permet de continuer vers le paste sans prolonger plus que de raison la gestion d'attente

@job75
c'est pas le paste qui ne s’exécute pas
il ne peut pas coller si le clip est occupé en remplissage c'est tout(il est facile de comprendre pourquoi) ;)
 

Anthonymctm

XLDnaute Occasionnel
Bonjour le fil et merci beaucoup pour vos réponses ! :D

un range qui porte le meme nom que son sheets parent heu........comment dire heu....... ;)

Alors en effet, je sais pas si ça pose problème ^^ Mais en tout cas les ça bug aussi sur les autres onglets que CGV alors que là les ranges sont "page_X". D'ailleurs d'un onglet à l'autre les ranges ont le même nom, mais je crois qu'elles sont bien identifiées par leur onglet. (C'est la page_03 de l'onglet En_tête)

C'est sûr que le problème vient de la non-exécution de Paste, il faut une boucle d'attente comme j'ai fait ici :
https://www.excel-downloads.com/threads/vba-pop-up.20037886/page-3#post-20270773

Je suis pas sûr de tout comprendre, c'est ça que je dois ajouter dans ma boucle ?
VB:
 While .Shapes.Count = 0 'en attente du collage
        DoEvents

comme je l'ai indiqué plusieurs fois dans ce forum et ailleurs l'api isclipboardformatavailable avec argument "2" pour bitmap ou 14 pour metafile dans un do/loop
est la seule qui te permet de continuer vers le paste sans prolonger plus que de raison la gestion d'attente
Patrick, tu penses que je dois passer par l'api isclipboardformatavailable (aucune idée de ce que c'est ^^') ou au contraire opter pour la boucle d'attente de Job ? o_O
 

patricktoulon

XLDnaute Barbatruc
Bonjour
une boucle d'attente sert a quoi ?
a temporiser avant l’exécution du reste du code
dans cet exemple on a besoins de quoi ?
attendre que le clipborad digère la copie en bitmap ou metafile (selon xlbitmap ou xlpicture)

tu peux faire une gestion d'attente avec api sleep
sauf que tu sais jamais le temps exact qu'il faut attendre selon les pc et configuration (des fois trop long des fois trop court)

tu peux faire une gestion d'attente avec un simple do loop sur timer
sauf que tu sais jamais le temps exact qu'il faut attendre selon les pc et configuration(des fois trop long des fois trop court)

etc...etc...(il y a plein de solution plus ou moins alambiquées)

et enfin tu fait une gestion d'attente avec l'api isclipboardformatavailable qui te dis si oui ou non le bitmap ou metafile est dans le clip
ainsi on sort de la gestion d'attente quand l'image(bitmap ou metafile) est bien dans le clipboard (pas une mili seconde plus ou de moins)


a partir de 2013 plus on va vers les versions sup de excel plus on a des lenteurs avec le clipboard
 

Discussions similaires

Statistiques des forums

Discussions
315 098
Messages
2 116 189
Membres
112 679
dernier inscrit
Yupanki