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 |
