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
| Option Explicit
Sub Macro1()
Dim docDP As Document, NomFichierSource, nomFichierDestination, nomfich As String
Set docDP = ActiveDocument
Dim WSHShell, desktop, pathstring, objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WSHShell = CreateObject("WScript.Shell")
desktop = WSHShell.SpecialFolders("Desktop")
pathstring = objFSO.GetAbsolutePathName(desktop)
NomFichierSource = Dir(pathstring & "\" & "*.xls", vbNormal)
With ActiveDocument
.MailMerge.OpenDataSource Name:= _
pathstring & "\" & NomFichierSource, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & pathstring & "\" & NomFichierSource & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=" _
, SQLStatement:="SELECT * FROM `Clients$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
.LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
End With
.Execute Pause:=False
End With
nomfich = Word.ActiveDocument.Name
MsgBox nomfich
NomFichierSource = Left(NomFichierSource, Len(NomFichierSource) - 17)
nomFichierDestination = NomFichierSource & "_CBV-VC-AVP"
ChangeFileOpenDirectory pathstring
ActiveDocument.SaveAs FileName:=pathstring & "\" & nomFichierDestination, FileFormat:=wdF
MsgBox nomFichierDestination
MsgBox (nomFichierDestination & " a bien été enregistré sur le bureau")
docDP.Close wdDoNotSaveChanges
End Sub |
Partager