Private Sub btn_fermer_Click()
Dim Appli As Object
Dim SessionOutlook, myOlApp
Const Chemin As String = "C:\Program Files (x86)\Microsoft Office\root\Office16\OUTLOOK.exe"
On Error Resume Next
Set Appli = GetObject(, "Outlook.Application")
If Appli Is Nothing Then
MsgBox "Outlook est fermé"
SessionOutlook = Shell(Chemin, 1)
sauvegarde_fichier_fermeture
envoi_mail_fermeture
Else
sauvegarde_fichier_fermeture
envoi_mail_fermeture
End If
End Sub
Sub sauvegarde_fichier_fermeture()
Dim dossier1 As String
Dim fichier As String
Dim datevalidation As String
Dim datevalidationmaj As String
datevalidation = Date
datevalidationmaj = Format(Date, "DD-mm-yy")
dossier1 = Sheets("dossier").Range("b2")
fichier = Sheets("dossier").Range("C2")
ActiveWindow.SmallScroll Down:=-100
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs Filename:=dossier1 & fichier & " - " & datevalidationmaj, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
Dim dossier2 As String
Dim fichier2 As String
dossier2 = Sheets("dossier").Range("b4")
fichier2 = Sheets("dossier").Range("C4")
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs Filename:=dossier2 & fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
Application.DisplayAlerts = True
End Sub
Sub envoi_mail_fermeture()
Dim xOutlook As Object
Dim xMailItem As Object
Dim xEmailAddr As String
Dim xEmailAddrCC As String
On Error Resume Next
Dim dossier1 As String
Dim fichier As String
Dim datevalidation As String
Dim datevalidationmaj As String
datevalidation = Date
datevalidationmaj = Format(Date, "DD-mm-yy")
dossier1 = Sheets("dossier").Range("b2")
fichier = Sheets("dossier").Range("C2")
Set xOutlook = CreateObject("Outlook.Application")
Set xMailItem = xOutlook.CreateItem(0)
Worksheets("Dossier").Activate
Sheets("Dossier").Range("CELL_ADRESSE_MAIL").Select
ActiveCell.Offset(1, 0).Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value <> "" Then
If xEmailAddr = "" Then
xEmailAddr = ActiveCell.Value
Else
xEmailAddr = xEmailAddr & ";" & ActiveCell.Value
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
If xEmailAddr <> "" Then
With xMailItem
.To = xEmailAddr
.CC = xEmailAddrCC
.Subject = "Essai Fermeture fichier " & datevalidationmaj
.Attachments.Add dossier1 & fichier & " - " & datevalidationmaj & ".xlsm"
.display
.Send
End With
Set xOutlook = Nothing
Set xMailItem = Nothing
End If
Combo_user = ""
TextBox_mdp = ""
Application.ScreenUpdating = True
End Sub