Macro instable Copier/Coller Image
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 :
Code:
1
2
| .CopyPicture Appearance:=xlScreen, Format:=xlPicture
.paste |
Pour remplacer l'ancien :
Code:
1
2
3
| .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. 8-)
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) :calim2:
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
Si besoin je peux vous laisser un fichier exemple qui reproduit le même phénomène. Le code en question est ci dessous :
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
| 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 |
NB : Une personne me propose d'enregistrer temporairement les images copiées pour ensuite les insérer sous word. Sauf que je ne comprend pas comment faire. :(
