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+

patricktoulon

XLDnaute Barbatruc
bonsoir

un exemple rapido
VB:
#If win64 Then
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#Else
    '32 bits
    Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As Long
#End If

Sub test()
Dim Avail&
Sheets(1).Range("A1:C4").CopyPicture xlScreen, xlBitmap

Avail = 3
'0 ou 14 ou 2  pour 0=image bitmap(xlbitmap) ou 14=metafile(xlpicture) 2=Cf_bitmap screencapture par les touches
Do: DoEvents: Avail = IsClipboardFormatAvailable(0): Debug.Print Avail: Loop While Avail = 3
 Sheets(3).Pictures.Paste
End Sub
 

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Test XL-WD (1).xlsm
    844.7 KB · Affichages: 13

Anthonymctm

XLDnaute Occasionnel
Bonjour Job, Bonjour Patrick,

Merci à tous les deux pour votre aide ! :)

J'ai opté pour la méthode de Job qui plus simple à mettre en place pour moi.
Par contre on est d'accord, dans le fichier Exemple tu n'as pas mis le On Error Resume Next ?

Je l'ai mis au tout début, c'est bon ?
VB:
Sub export_excel_to_word()
    On Error Resume Next
    Dim obj As Object
    Dim newObj As Object
    Dim sh As Worksheet
    Dim myFile
Application.ScreenUpdating = False

Merci encore ! :D
 

Discussions similaires

Réponses
16
Affichages
1 K

Statistiques des forums

Discussions
311 710
Messages
2 081 781
Membres
101 817
dernier inscrit
carvajal