Sub MergeIt()
Dim objWord As Word.Document
Set objWord = GetObject("C:\Local Data\Access\Publipostage\Publipostage.doc", "Word.Document")
' Rend Word visible important puisque la fusion se fait à l'écran.
objWord.Application.Visible = True
' Sélectionne .la base de données Comptoir comme source de données pour la fusion
objWord.MailMerge.OpenDataSource _
		Name:="C:\Local Data\Access\Publipostage\Comptoir.mdb", _
		LinkToSource:=True, _
		Connection:="TABLE Employés", _
		SQLStatement:="SELECT * FROM [Employés]"
' Exécution de la fusion.
objWord.MailMerge.Execute
Set objWord = Nothing
					
End Sub

Private Sub cmdMergeIt_Click()

Call MergeIt

End Sub

Sub MergeBM()
Dim wApp As Word.Application
Dim chemin As String
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim sql As String
sql = "SELECT * from Employés"

Set db = CurrentDb
Set rs = db.OpenRecordset(sql)
Set wApp = New Word.Application
    chemin = currentproject.path
wApp.Visible = True

While Not rs.EOF
With wApp
    .Documents.Open (chemin & _\BM Publipostage.doc_)
    .ActiveDocument.Bookmarks("nom").Range.Text = rs.Fields("nom")
    .ActiveDocument.Bookmarks("prenom").Range.Text = rs.Fields("prénom")
    .ActiveDocument.PrintOut
    .ActiveDocument.Close (wdDoNotSaveChanges)
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing

Set wApp = Nothing
End Sub

Private Sub cmdMergeBM_Click()

Call MergeBM

End Sub

Private Sub CmdExportWord_Click()
Call TrfText(idContrat)

End Sub

'******************************************************************************
'*  Procédure pour l'export de texte vers un document Word
'*  Utilisé dans le cadre d'un tuto pour le publipostage
'*
'******************************************************************************
Public Sub TrfText(idctrt As Integer)
Dim rs01 As Recordset
Dim rs02 As Recordset 'recordset de la table client
Dim rs03 As Recordset 'recordset de la table clause
Dim db As Database
Dim stSQL01 As String
Dim stSQL02 As String
Dim stSQL03 As String
Dim strChemin As string
strChemin = CurrentProject.Path
Dim wApp As Word.Application
Set wApp = New Word.Application
wApp.Visible = True 'permet d'afficher à l'écran le transfert de texte

'ouverture du document Word
wApp.Documents.Open strChemin & "\contrat.doc"
stSQL01 = "Select * from tblcontrat where idcontrat =" & idctrt
Set db = CurrentDb
Set rs01 = db.OpenRecordset(stSQL01) 'défnition du premier recordset table contrat
'insérer le code d'appel pour insertion dans Word
With wApp.Selection
	.TypeParagraph 'ajoute une ligne en Word
    .TypeText "Contrat  " 'insertion de donnée de type texte
    .TypeText rs01.Fields("idContrat") 'insertion des données issues du recordset
    .TypeParagraph
    .TypeText "En date du  " & rs01.Fields("dtDate")
    .TypeParagraph
    .TypeParagraph
End With
stSQL02 = "select * from tblclient where idclient =" & rs01.Fields("idclient").Value
Set rs02 = db.OpenRecordset(stSQL02) 'définition du second recordset table client
With wApp.Selection
     .TypeParagraph
     .TypeParagraph
     .TypeText rs02.Fields("sttitre") & " " & rs02.Fields("stNom")
     .TypeParagraph
     .TypeText rs02.Fields("stAdresse")
     .TypeParagraph
     .TypeText rs02.Fields("stCP") & "  " & rs02.Fields("stville")
     .TypeParagraph
     .TypeParagraph
End With

stSQL03 = "SELECT tblContrat.idContrat, tblClause.idClause, tblClause.stRubrique, " _& 
          "tblClause.stClause " _ & 
		  "FROM tblContrat INNER JOIN (tblClause INNER JOIN tblDetailContrat " _ & 
		  "ON tblClause.idClause = tblDetailContrat.idClause) "_ &
		  "ON tblContrat.idContrat = tblDetailContrat.idContrat " _& 
		  "WHERE tblContrat.idContrat= " & rs01.Fields("idcontrat")
Set rs03 = db.OpenRecordset(stSQL03) 'définition de roisième recordset table clause
	While Not rs03.EOF 'boucle pour récuperer les enreistrments de la table liée
		With wApp.Selection
	        .TypeText rs03.Fields("strubrique")
	        .TypeParagraph
	        .TypeText rs03.Fields("stclause")
	        .TypeParagraph
	        .TypeParagraph
        End With
    rs03.MoveNext
	Wend
' libération des objets
'afin de pourvoir manipuler le fichier Word, l'application n'est pas fermée
Set rs01 = Nothing
Set rs02 = Nothing
Set rs03 = Nothing
Set db = Nothing
End Sub

stSQL03 = "SELECT tblContrat.idContrat, tblClause.idClause, tblClause.stRubrique, tblClause.stClause 
FROM tblContrat INNER JOIN (tblClause INNER JOIN tblDetailContrat ON tblClause.idClause = tblDetailContrat.idClause) 
ON tblContrat.idContrat = tblDetailContrat.idContrat WHERE tblContrat.idContrat= " & rs01.Fields("idcontrat")

Public Sub publipost()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim db As DAO.Database
Dim rs As DAO.Recordset
 
Set db = CurrentDb
Set rs = db.OpenRecordset("select * from tbl_nomImages")
Set oWord = New Word.Application
 
While Not rs.EOF
    oWord.Documents.Add ("c:\local data\images\images.dot")
    oWord.ActiveDocument.Bookmarks("bm1").Select
        Selection.TypeText rs.Fields(1)
    oWord.ActiveDocument.Bookmarks("image").Select
        Selection.InlineShapes.AddPicture FileName:=rs.Fields(2), linktofile:=False, savewithdocument:=True
        
    oWord.ActiveDocument.SaveAs "c:\local data\images\" & rs.Fields(1) & ".doc"
    oWord.ActiveDocument.Close
    rs.MoveNext
Wend
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
oWord.Quit
End Sub

Public Sub EnvoiMassif()
'Ajouter les références suivantes :
'Microsoft Outlook
'Microsoft DAO
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim oDB As DAO.Database
Dim strContenu As String
Dim oRst0 As DAO.Recordset
Dim oRst1 As DAO.Recordset
Dim strTo As String
Dim sqlMail As String
'Instancie Outlook
Set oDB = CurrentDb
Set oApp = CreateObject("Outlook.Application")
'Crée un nouveau message
sqlMail = "SELECT  * FROM tblMessage;"
Set oRst0 = oDB.OpenRecordset(sqlMail)
oRst0.MoveLast
Set oMail = oApp.CreateItem(olMailItem)
oMail.Body = oRst0.Fields("txtcorps")
oMail.Subject = oRst0.Fields("strObjet") & " du " & oRst0.Fields("dtCrea")
'Ouvre un recordset sur les clients
Set oRst1 = oDB.OpenRecordset("SELECT stEmail FROM tblClient")
'Boucle sur chaque client et les ajoute au champ BCC du mail
While Not oRst1.EOF
	strTo = strTo & oRst1.Fields("stEmail") & "; "
	oRst1.MoveNext
Wend
'Supprime la dernière virgule
oMail.BCC = Left(strTo, Len(strTo) - 2)
'Envoi du mail
oMail.Send
oRst0.Close
oRst1.Close
Set oRst0 = Nothing
Set oRst1 = Nothing
Set oDB = Nothing
'Ferme Outlook
oApp.Quit
Set oApp = Nothing
End Sub

While Not oRst1.EOF
strTo = strTo & oRst1.Fields("stEmail") & "; "
oRst1.MoveNext
Wend

Private Sub cmdeSendHtml_Click()
Call htmlMail
End Sub

Public Sub htmlMail()
Dim strHTML As String
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim oDB As DAO.Database
Dim strContenu As String
Dim oRst0 As DAO.Recordset
Dim oRst1 As DAO.Recordset
Dim strTo As String
Dim sqlMail As String
Set oDB = CurrentDb
Set oApp = CreateObject("Outlook.Application")
'Crée un nouveau message
sqlMail = "SELECT  * FROM tblMessage;"
Set oRst0 = oDB.OpenRecordset(sqlMail)
oRst0.MoveLast
Set oMail = oApp.CreateItem(olMailItem)
strHTML = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.0 Transitional//EN"">" & _
          "<HTML><HEAD>" & _
          "<META http-equiv=Content-Type content=""text/html; charset=iso-8859-1"">" & _
          "<META content=""MSHTML 6.00.2800.1516"" name=GENERATOR></HEAD>" & _
          "<BODY><DIV STYLE=""font-size: 16px; font-face: Tahoma;"">"
oMail.HTMLBody = strHTML & oRst0.Fields("txtCorps") & "<hr>" & "</DIV></BODY></HTML>"
oMail.Subject = oRst0.Fields("strObjet") & " du " & oRst0.Fields("dtcrea")
'Ouvre un recordset sur les clients
Set oRst1 = oDB.OpenRecordset("SELECT stEmail FROM tblClient")
'Boucle sur chaque client et les ajoute au champ BCC du mail
While Not oRst1.EOF
	  strTo = strTo & oRst1.Fields("stEmail") & "; "
	  oRst1.MoveNext
Wend
'Supprime la dernière virgule
oMail.BCC = Left(strTo, Len(strTo) - 2)
'Envoi le mail
oMail.Send
'ferme le curseur
oRst0.Close
oRst1.Close
Set oRst0 = Nothing
Set oRst1 = Nothing
Set oDB = Nothing
'Ferme Outlook
oApp.Quit
Set oApp = Nothing
End Sub