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 79 80 81 82 83 84 85 86 87
| Dim docWord As Word.Document
Dim appWord As Word.Application
Dim NomBase As String
Dim TabTarif As Range
Dim I As Integer
Dim cheminPergo As String
Dim Dossier As String
Dim Dossier2 As String
Dim Fichier As String
Dim tmpChemin As String
Dim tmpFichier As String
For I = 1 To 20
If (Worksheets("tmptarif").Range("A" & I).Value <> "") Then
I = I + 1
Else
Exit For
End If
Next I
Set TabTarif = Workbooks("0A-H-A calcul VBA").Worksheets("tmptarif").Range("A1:B" & I - 1)
TabTarif.Copy
NomBase = "D:\ahaVBA\0A-H-A calcul VBA.xlsm"
Set appWord = CreateObject("Word.Application")
appWord.Visible = True
Set docWord = appWord.Documents.Open("D:\ahaVBA\DevisAHA.docx", ReadOnly:=False)
docWord.Bookmarks("TableauTarif").Select
appWord.Selection.PasteSpecial link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
docWord.Tables(1).AutoFitBehavior wdAutoFitWindow
Application.CutCopyMode = False
With docWord.mailMerge
'Ouvre la base de données
.OpenDataSource Name:=NomBase, _
Connection:="Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & NomBase & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [tmpBDD$]"
'''' 'Spécifie la fusion vers l'imprimante
'''' .Destination = wdSendToPrinter
.suppressBlankLines = True
'''' 'Prend en compte l'ensemble des enregistrements
With .DataSource
.firstRecord = wdDefaultFirstRecord
' .lastRecord = wdDefaultLastRecord
End With
'Exécute l'opération de publipostage
.Execute Pause:=False
End With
Application.ScreenUpdating = True
cheminPergo = "D:\Pergola Alu - Verrière -Puit de Lumière"
Dossier = UCase(Left(ufFicheClient.tbNom, 1)) & LCase(Mid(ufFicheClient.tbNom, 2)) & " " & "(" & UCase(Left(ufFicheClient.tbVille, 1)) & LCase(Mid(ufFicheClient.tbVille, 2)) & ")"
Dossier2 = UCase(Left(ufFicheClient.tbNom, 1)) & LCase(Mid(ufFicheClient.tbNom, 2)) & " " & UCase(Left(ufFicheClient.tbPrenom, 1)) & LCase(Mid(ufFicheClient.tbPrenom, 2)) _
& " " & "(" & UCase(Left(ufFicheClient.tbVille, 1)) & LCase(Mid(ufFicheClient.tbVille, 2)) & ")"
Fichier = UCase(Left(ufFicheClient.tbNom, 1)) & LCase(Mid(ufFicheClient.tbNom, 2)) & " " & Format(Day(Date), "00") & Format(Month(Date), "00") & Format(Year(Date), "00")
If (Worksheets("tmpBDD").Range("AU2").Value <> "") Then
tmpChemin = cheminPergo & "\" & Dossier2
MkDir (tmpChemin)
appWord.ActiveDocument.ExportAsFixedFormat OutputFileName:=tmpChemin & "\" & Fichier & ".pdf", ExportFormat:= _
17, OpenAfterExport:=True, OptimizeFor:=0, Range:=0, From:=1, To:=4, Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=0, DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
DoEvents
' appWord.Close True
Else
tmpChemin = cheminPergo & "\" & Dossier
MkDir (tmpChemin)
appWord.ActiveDocument.ExportAsFixedFormat OutputFileName:=tmpChemin & "\" & Fichier & ".pdf", ExportFormat:= _
17, OpenAfterExport:=True, OptimizeFor:=0, Range:=0, From:=1, To:=1, Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=0, DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
DoEvents
' appWord.Close True
End If
Else
End If
Unload Me
Unload ufChiffrage
Unload ufrecap
Unload ufFicheClient
Unload ufTypeClient |
Partager