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
|
Sub ExcelWord_V2()
Dim WordApp As Object, AppDoc As Object, MaForme As Object
Dim MyFile As String
Dim NbInLineShape As Integer
With ActiveWorkbook
MyFile = .Path & "\" & Replace(.Name, "xlsm", "docx") 'remplacer "docx" par l'extension qui convient, si nécessaire
.Worksheets("En_tête").Range("page_01").Copy
End With
Set WordApp = CreateObject("Word.Application")
With WordApp
.Visible = True
Set AppDoc = .Documents.Add
End With
With AppDoc
.PageSetup.TopMargin = WordApp.CentimetersToPoints(1)
.PageSetup.BottomMargin = WordApp.CentimetersToPoints(1)
End With
'WordApp.Selection.PasteSpecial Link:=True, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False
' WordApp.Selection.PasteSpecial Link:=True, DataType:=4, Placement:=0, DisplayAsIcon:=False
' WordApp.Selection.PasteSpecial Link:=True, DataType:=10, Placement:=0, DisplayAsIcon:=False ' Format HTML
WordApp.Selection.PasteSpecial Link:=True, DataType:=2, Placement:=0, DisplayAsIcon:=False ' Format Text
With AppDoc
NbInLineShape = .inlineshapes.Count
If NbInLineShape > 0 Then
Set MaForme = .inlineshapes(NbInLineShape).ConvertToShape
With MaForme
Debug.Print .Top
.Width = 460.8
.Left = 69.5
End With
Set MaForme = Nothing
End If
End With
' AppDoc.SaveAs2 Filename:=MyFile, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
' AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
' EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
AppDoc.SaveAs2 Filename:=MyFile, FileFormat:=12, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False ', CompatibilityMode:=14
WordApp.Activate 'vous pouvez jouer sur les marges pour améliorer la lecture
MsgBox "Export vers Word terminé", vbInformation + vbOKOnly, "Export vers Word"
Set WordApp = Nothing
Set AppDoc = Nothing
End Sub |
Partager