Sub Lettre()
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim i As Integer
Dim vDossierDestination As String
Dim vDossierSource As String
Dim vEtatCivil As String
Dim vPrénom As String
Dim vNom As String
Dim vRue As String
Dim vCodePostal As String
Dim vLocalité As String
Dim vNomDoc As String
Dim vDate As String
Dim vErreur As Integer
Dim vMessage As String
Dim vColonne As Integer
vDossierSource = "C:\Document\"
vDossierDestination = "C:\Document\"
ActiveSheet.Cells(ActiveCell.Row, 1).Select
If IsEmpty(ActiveCell) Then
MsgBox "Cliquez dans la ligne du contact auquel vous voulez écrire. ", vbOKOnly, "Erreur"
Exit Sub
End If
'With ActiveCell
vEtatCivil = ActiveCell.Value
vPrénom = ActiveCell.Offset(0, 1)
vNom = ActiveCell.Offset(0, 2)
vRue = ActiveCell.Offset(0, 3)
vCodePostal = ActiveCell.Offset(0, 4)
vLocalité = ActiveCell.Offset(0, 5)
'End With
vErreur = 0
If vLocalité = "" Then vErreur = 1
If vCodePostal = "" Then vErreur = 2
If vRue = "" Then vErreur = 3
If vNom = "" Then vErreur = 4
If vEtatCivil = "" Then vErreur = 5
Select Case vErreur
Case Is = 5
vMessage = "L'état civil manque."
vColonne = 0
Case Is = 4
vMessage = "Le nom du contact manque."
vColonne = 2
Case Is = 3
vMessage = "La rue manque."
vColonne = 3
Case Is = 2
vMessage = "Le code postal manque."
vColonne = 4
Case Is = 1
vMessage = "La localité manque."
vColonne = 5
End Select
If vErreur > 0 Then
MsgBox vMessage, vbOKOnly, "Erreur"
ActiveCell.Offset(0, vColonne).Select
Exit Sub
End If
ActiveCell.Offset(0, 6) = DateSerial(Year(Range("A1")), Month(Range("A1")), Day(Range("A1")))
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Open(vDossierSource & "lettre.doc")
With wordDoc.ActiveWindow.Selection
.HomeKey Unit:=wdStory
.MoveDown Unit:=wdParagraph, Count:=6
.TypeText Text:=vEtatCivil & " " & vPrénom & " " & vNom
.TypeParagraph
.TypeText Text:=vRue
.TypeParagraph
.TypeText Text:=vCodePostal & " " & vLocalité
.TypeParagraph
.MoveDown Unit:=wdParagraph, Count:=3
.TypeText Text:=vEtatCivil & ", "
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeText Text:="Veuillez agréer, " & vEtatCivil & ", mes meilleures salutations."
.WholeStory
.Fields.Unlink
.EndKey Unit:=wdStory
.MoveUp Unit:=wdParagraph, Count:=4
End With
vDate = Range("A1")
vNomDoc = vNom & vDate
wordDoc.SaveAs (vDossierDestination & vNomDoc)
Set wordDoc = Nothing
Set wordApp = Nothing
End Sub
