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
| Dim stLinkCriteria As String, strSql As String, sFichModele As String
Dim maBD As DAO.Database
Dim strRQ1 As String
Dim QDF1 As DAO.QueryDef
Dim QDF2 As DAO.QueryDef
Dim rst1 As DAO.Recordset, rst2 As DAO.Recordset
Dim wrdApp As Word.Application 'en ref: Microsoft Word Object library 9,0
Dim stDocName As String
'********************************************************
' Sélection du document type
'********************************************************
...
Debug.Print sFichModele
'********************************************************
Set maBD = CurrentDb
'********************************************************
Set QDF1 = maBD.QueryDefs("rq_OrgCorr")
'MsgBox "qdf:" & vbCr & qdf.SQL
stLinkCriteria = addCritere
'MsgBox "stLinkCriteria " & vbCr & stLinkCriteria
strRQ1 = Left(QDF1.SQL, Len(QDF1.SQL) - 3) & " WHERE " & stLinkCriteria
'on doit retirer un certain nb de car (dont ;) à la& fi de QDF.SQL
'MsgBox " requete avec les criteres: " & vbCr & strRQ1
Set rst2 = maBD.OpenRecordset(strRQ1)
If rst2.RecordCount > 0 Then
If ExistQuery("rtmp_orgCorr") Then maBD.QueryDefs.Delete ("rtmp_orgCorr")
Set QDF2 = maBD.CreateQueryDef("rtmp_orgCorr", strRQ1)
Set wrdApp = CreateObject("Word.Application")
With wrdApp
.Visible = True
'ouvrir le document
.Documents.Open sFichModele
'diriger le pblg vers un autre document
.ActiveDocument.MailMerge.Execute
End With
Else ' no record found
MsgBox "Aucun enregistrement ne correspond aux critères saisis", _
vbExclamation, "Aucun enregistrement trouvé"
End If
Set rst1 = Nothing
Set rst2 = Nothing
Set wrdApp = Nothing
Set QDF1 = Nothing
Set QDF2 = Nothing
Set rst2 = Nothing
Set maBD = Nothing |
Partager