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
| Option Explicit
Public Const wdDefaultFirstRecord = 1
Public Const wdDefaultLastRecord = -16
Sub Publipostage()
'======================================================================
' Exécution d'un Publipostage
'======================================================================
Dim NDXL As String, NDF As String, NDF2 As String, Rep As String
Dim WordApp As Object ' Word.Application
Dim WordDoc As Object ' Word.Document
Application.ScreenUpdating = False
NDXL = ActiveWorkbook.Path & "\Clients.xlsx"
NDF = ActiveWorkbook.Path & "\Nom.docx"
Rep = ActiveWorkbook.Path & "\SousDossier\"
If Not ExisteRep(Rep) Then MkDir Rep
NDF2 = Rep & "Voeux_" & Format(Now(), "yyyymmddhhmm")
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
With WordDoc.mailMerge
.OpenDataSource Name:=NDXL, Connection:="Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & NDXL & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [Liste$]"
'.Destination = wdSendToPrinter 'Si besoin de fusion vers l'imprimante
.suppressBlankLines = True
With .DataSource
'.firstRecord = wdDefaultFirstRecord
'.lastRecord = wdDefaultLastRecord
.firstRecord = 1
.lastRecord = 3
End With
.Execute Pause:=False 'Exécute l'opération de publipostage
End With
WordDoc.Application.ActiveDocument.SaveAs NDF2
WordDoc.Application.ActiveDocument.Close
'WordApp.Application.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
Application.ScreenUpdating = True
MsgBox "Publipostage OK"
End Sub
Function ExisteRep(NDF As String) As Boolean
On Error Resume Next
ExisteRep = GetAttr(NDF) And vbDirectory
End Function |
Partager