Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !
Bonjour,
Pas mal de soucis avec: courriels bloques cote server et le plus souvent en pourriels
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" '---> tu adaptes ce chemin si c'est nécessaire
On Error Resume Next
Set Appli = GetObject(, "Outlook.Application")
'Tester si l'application est ouverte ou non
If Appli Is Nothing Then
MsgBox "Outlook est fermé" '---> Donc ouvre moi une session
SessionOutlook = Shell(Chemin, 1)
'sauvegarde fichier
sauvegarde_fichier_fermeture
' envoi MAIL
envoi_mail_fermeture
Else
'sauvegarde fichier
sauvegarde_fichier_fermeture
' envoi MAIL
envoi_mail_fermeture
End If
'Set myOlApp = CreateObject("Outlook.Application")
' myOlApp.Quit
'Application.Quit
End Sub
Sub sauvegarde_fichier_fermeture()
'sauvegarde fichier
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 'repositionner ecran
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs Filename:=dossier1 & fichier & " - " & datevalidationmaj, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
'sauvegarde fichier_bureau
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
' Message de confirmation
'MsgBox ("Le fichier a bien été sauvegardé" & vbCrLf & vbCrLf & "Merci ")
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)
'Selection de la page des adresses mail
Worksheets("Dossier").Activate
'Selection de la cellule nommée 'CELL_ADR_MAIL' représentant le nom de la colonne des mails dans le tableau
Sheets("Dossier").Range("CELL_ADRESSE_MAIL").Select
'Déplacement d'une ligne en dessous pour débuter la boucle de lecture des adresses mail
ActiveCell.Offset(1, 0).Select
Do Until IsEmpty(ActiveCell)
'If ActiveCell.Value Like "*@*" Then ' si celulle active contient une adresse mail
If ActiveCell.Value <> "" Then ' si cellule active non vide
If xEmailAddr = "" Then
xEmailAddr = ActiveCell.Value
Else
xEmailAddr = xEmailAddr & ";" & ActiveCell.Value
End If
End If
'Lecture de l'adresse mail suivante, une ligne en dessous
ActiveCell.Offset(1, 0).Select
Loop
'Si la liste des adresses mail n'est pas vide on diffuse
If xEmailAddr <> "" Then
With xMailItem
.To = xEmailAddr
.CC = xEmailAddrCC
.Subject = "Essai Fermeture fichier " & datevalidationmaj
'.body = "Bonjour,"
.Attachments.Add dossier1 & fichier & " - " & datevalidationmaj & ".xlsm"
.display
.Send 'validation envoi
End With
Set xOutlook = Nothing
Set xMailItem = Nothing
End If
Combo_user = ""
TextBox_mdp = ""
'Annule le Masquage l'éxécution de la macro
Application.ScreenUpdating = True
End Sub'Set myOlApp = CreateObject("Outlook.Application")
' myOlApp.Quit
'Application.QuitDim ProcessId As LongPtr
Sub test()
ProcessId = Shell("C:\Program Files (x86)\Microsoft Office\Office15\OUTLOOK.EXE", vbNormal)
With CreateObject("outlook.application")
Set Email = .CreateItem(0)
With Email
.Subject = "toto"
.body = "coucou"
.display
'.send
End With
End With
End Sub
Sub fermeoutlook()
Set WMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set ProcessList = WMIService.ExecQuery("Select * from Win32_Process Where Name = 'Outlook.exe'")
'le problème est que chaque instance est enfant de la première
'donc quand je ferme celle dont j'ai le processID toute les autres sont fermées aussi
For Each process In ProcessList
If process.Handle = ProcessId Then process.Terminate
Next
End Sub
