Sub GESTION_DEVIS()
Dim s_date As Date
'----- Récupération des signets du WORD -----
s_Num_devis = ActiveDocument.Bookmarks("Num_devis").Range.Text
s_date = ActiveDocument.Bookmarks("Date").Range.Text
s_prénom_nom = ActiveDocument.Bookmarks("prénom_nom").Range.Text
s_client = ActiveDocument.Bookmarks("Client").Range.Text
s_adresse_mail = ActiveDocument.Bookmarks("adresse_mail").Range.Text
s_Intitulé = ActiveDocument.Bookmarks("Intitulé").Range.Text
'--------------------------------------------
'----- Vérification de l'indice -----
nett_s_Num_devis = nettoyage(s_Num_devis)
str_indice = "-IND"
If InStr(1, nett_s_Num_devis, str_indice, vbTextCompare) = 0 Then
MsgBox ("Il manque l'indice sur le nom du devis: ex JD_0001 - Ind A !")
End
End If
'------------------------------------
'----- Sauvegarde du fichier WORD -----
temp_ = Split(nett_s_Num_devis, str_indice)
Num_devis = temp_(0)
Ind_devis = temp_(1)
Application.DisplayAlerts = False
If ActiveDocument.Path = "" Then
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "C:\temp"
.Show
If .SelectedItems.Count > 0 Then
Dossier = .SelectedItems(1) & "\"
Else
MsgBox ("Merci de choisir un dossier! -> FIN")
End
End If
End With
ActiveDocument.SaveAs filename:=Dossier & s_Num_devis & ".docx"
If ActiveDocument.Path = "" Then End
Else
ActiveDocument.SaveAs filename:=ActiveDocument.Path & "\" & s_Num_devis & ".docx"
End If
Application.DisplayAlerts = True
DoEvents
'--------------------------------------
'----- Génération du fichier PDF -----
Dim chemin_nom As String
chemin = ActiveDocument.Path
nom = Split(ActiveDocument.Name, ".")(0) & ".pdf"
chemin_nom = chemin & "/" & nom
Select Case IsFileOpen(chemin_nom)
Case True
temp_10 = MsgBox("Merci de fermer le fichier :" & Chr(10) & Chr(10) & chemin_nom & Chr(10) & Chr(10) & " avant le l'enregistrer à nouveau !", vbCritical)
End
Case False
ActiveDocument.ExportAsFixedFormat OutputFileName:=chemin_nom, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True
End Select
DoEvents
'-------------------------------------
'-------- Génération du mail ---------
Dim appOutlook As Outlook.Application
Set appOutlook = Outlook.Application
Dim MESSAGE As Outlook.MailItem
Dim objRecipient As Outlook.Recipient
Set MESSAGE = appOutlook.CreateItem(olMailItem)
With MESSAGE
.Display
.Subject = "MGI : devis N°" & s_Num_devis & " (" & s_Intitulé & ")"
'on ajoute un Corps en TEXTE HTML
texte_mail = "<html><body><p>"
texte_mail = texte_mail & "Bonjour " & s_prénom_nom & "," & "</p>"
texte_mail = texte_mail & "<p>En réponse à votre consultation intitulée : <em><strong><u>" & s_Intitulé & "</em></strong></u>"
texte_mail = texte_mail & ", veuillez trouver ci-joint notre devis n°<em><strong><u>" & s_Num_devis & "</em></strong></u></p>"
texte_mail = texte_mail & "<p></p>"
texte_mail = texte_mail & "<p>En espérant un retour favorable de votre part sur cette offre.</p>"
texte_mail = texte_mail & .HTMLBody & "</body></html>" ' Ne pas oublier le .HTMLBody pour conserver la signature ;-)
.HTMLBody = texte_mail
'Ajout d'un destinataire principal
Set objRecipient = .Recipients.Add(s_adresse_mail)
objRecipient.Type = olTo 'olBCC, olCC, olOriginator ou olTo.
objRecipient.Resolve
'Ajout d 'une PJ si elle existe.
If Dir(chemin_nom) <> "" Then
.Attachments.Add chemin_nom
End If
End With
DoEvents
'-------------------------------------
'----- Sauvegarde dans la Base De Données -----
test_excel:
'lecture du tableau excel dans word pour trouver le TOTAL HT
Dim xlApp As Object
With ActiveDocument.InlineShapes(1).OLEFormat
'.Edit
.Activate
'.DoVerb
Set xlApp = GetObject(, "Excel.Application")
i = 2
While Not UCase(xlApp.Workbooks(1).Sheets(1).Cells(i, 4)) Like "*TOTAL*HT*"
i = i + 1
If i > 50 Then
MsgBox ("|Total HT| non trouvé!")
End
End If
Wend
Total_HT_devis = xlApp.Workbooks(1).Sheets(1).Cells(i, 5).Value
xlApp.Quit
'.Object.Application.Quit
End With
'sauvegarde dans la BDD
PathName = "C:\temp\"
filename = "SUIVI_DEVIS.xlsx"
sheetname = "SUIVI"
Dim appXl As Excel.Application
Dim ficXl As Excel.Workbook
'crée un nouvelle instance Excel
Set appXl = New Excel.Application
'ouvre le fichier
Set ficXl = appXl.Workbooks.Open(PathName & filename)
'lecture écriture dans la BDD
With appXl.Worksheets(sheetname)
i = 2
next_i:
cell_excel = nettoyage(.Cells(i, 3))
If cell_excel <> "" Then
temp_ = Split(cell_excel, str_indice)
cell_excel_Num_devis = temp_(0)
cell_excel_Ind_devis = temp_(1)
Select Case cell_excel_Num_devis
Case Is = Num_devis
'c'est le même numéro de devis
If Ind_devis = cell_excel_Ind_devis Then
'c'est le même indice de devis => on écrase les données précédentes
Else
'ce n'est pas le même indice de devis => on continue de chercher
i = i + 1
GoTo next_i
End If
Case Empty
'fin du fichier => on ajoute le nouveau devis
Case Else
' c'est un autre devis => on continue de chercher
i = i + 1
GoTo next_i
End Select
End If
'écriture des données sur la bonne ligne
.Cells(i, 1) = s_client
.Cells(i, 2) = s_prénom_nom
.Hyperlinks.Add Anchor:=.Cells(i, 3), Address:=ActiveDocument.Path & "\" & ActiveDocument.Name, ScreenTip:="Ouvrir devis", TextToDisplay:=s_Num_devis 'lien hypertexte permettant d'ouvrir le devis
.Cells(i, 4) = s_date
.Cells(i, 5) = NoSem(s_date)
.Cells(i, 6) = convert_month(Month(s_date))
.Cells(i, 7) = Year(s_date)
.Cells(i, 8) = s_Intitulé
.Cells(i, 9) = Total_HT_devis
End With
'sauve et ferme le fichier et quitte excel
appXl.DisplayAlerts = False
ficXl.SaveAs filename:=PathName & filename
appXl.DisplayAlerts = True
ficXl.Close
appXl.Quit
'----------------------------------------------
End Sub
Function IsFileOpen(filename As String) As Boolean
Dim filenum As Integer, Errnum As Integer
On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
Errnum = Err
On Error GoTo 0
Select Case Errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
End Select
End Function
Function nettoyage(texte)
nettoyage = Replace(texte, " ", "")
nettoyage = UCase(nettoyage)
End Function
Function convert_month(texte)
Select Case texte
Case 1
convert_month = "Janvier"
Case 2
convert_month = "Février"
Case 3
convert_month = "Mars"
Case 4
convert_month = "Avril"
Case 5
convert_month = "Mai"
Case 6
convert_month = "Juin"
Case 7
convert_month = "Juillet"
Case 8
convert_month = "Août"
Case 9
convert_month = "Septembre"
Case 10
convert_month = "Octobre"
Case 11
convert_month = "Novembre"
Case 12
convert_month = "Décembre"
Case Else
MsgBox ("erreur mois")
End
End Select
End Function
Function NoSem(d As Date) As Long
d = Int(d)
NoSem = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
NoSem = ((d - NoSem - 3 + (Weekday(NoSem) + 1) Mod 7)) \ 7 + 1
End Function
