top of page

'Module1

'Copier à partir de Outlook les pièces jointes d'un email vers un répertoire.

Sub SaveAttachment()
' https://outlook.developpez.com/faq/?page=VBA#vba_sauvegarder_pieces_jointes


   'Declaration
   Dim myItems, myItem, myAttachments, myAttachment As Object
   Dim myOrt As String
   Dim myOlApp As New Outlook.Application
   Dim myOlExp As Outlook.Explorer
   Dim myOlSel As Outlook.Selection
   Dim i As Integer
   
   'Boîte de dialogue simple pour le chemin de sauvegarde
   'myOrt = InputBox("Destination", "Save Attachments", "P:\Test\SourceFileAM\")
   myOrt = InputBox("Destination", "Save Attachments", "\\smb15-nas1.par.emea.cib\ISS_DATA\08 - I3C\91 - Controles Pulse\MOVIS PULSE EMEA Connections out of biz hours\SourceFileAM\")
   
   'MsgBox myOrt
   '--> rechercher en vba ooutlook si un folder exist. Sinon end Sub

   On Error Resume Next
   
   'Actions sur les objets sélectionnés
   Set myOlExp = myOlApp.ActiveExplorer
   Set myOlSel = myOlExp.Selection
   
   'boucle
   For Each myItem In myOlSel
       Set myAttachments = myItem.Attachments
       If myAttachments.Count > 0 Then
                   '------- deleted part
           'Ajoute une remarque dans le corps du message
           'myItem.Body = myItem.Body & vbCrLf & _
            '   "pièce jointe enlevée:" & vbCrLf
                '------- deleted part
                
           'for all attachments do...
           For i = 1 To myAttachments.Count
           
               'save them to destination
               myAttachments(i).SaveAsFile myOrt & _
                   myAttachments(i).DisplayName
               myItem.Body = myItem.Body & _
                   "File: " & myOrt & _
                   myAttachments(i).DisplayName & vbCrLf
                   
           Next i
           
            '------- deleted part
           'Enlève les pièces jointes du message
          ' While myAttachments.Count > 0
           
          '     myAttachments(1).Delete
               
         '  Wend
          '------- deleted part
           
           'Sauvegarde le message sans ses pièces jointes
           myItem.Save
       End If
       
   Next
   
   Set myItems = Nothing
   Set myItem = Nothing
   Set myAttachments = Nothing
   Set myAttachment = Nothing
   Set myOlApp = Nothing
   Set myOlExp = Nothing
   Set myOlSel = Nothing
   

   
   Call OuvrirVisibleExcel
   
End Sub




 

'Module2

Sub OuvrirVisibleExcel()
'https://forum.hardware.fr/hfr/Programmation/VB-VBA-VBS/ouvrir-excel-outlook-sujet_140477_1.htm

Set XLapp = CreateObject("Excel.Application")
XLapp.Visible = True
'XLapp.Workbooks.Open "P:\Test\TEST.xlsm" 'test
'XLapp.Workbooks.Open "P:\Test\YYYYMMDD - BG - MOVIS PULSE EMEA connections out of biz hours with Mail.xlsm" 'Local
'XLapp.Workbooks.Open "P:\Test\YYYYMMDD - AUTO - MOVIS PULSE EMEA connections out of biz hours with Mail.xlsm" ' AUTO Local
XLapp.Workbooks.Open "\\smb15-nas1.par.emea.cib\ISS_DATA\08 - I3C\91 - Controles Pulse\MOVIS PULSE EMEA Connections out of biz hours\YYYYMMDD - BG - MOVIS PULSE EMEA connections out of biz hours with Mail.xlsm" 'répertoire paratgé
'Application.Activate
'MsgBox XLapp.ActiveWorkbook.Name & " : " & XLapp.ActiveSheet.Name
'XLapp.Quit
Set XLapp = Nothing
End Sub




 

'Module3

 

'Macro Standard
'https://forum.excel-pratique.com/excel/macro-enregistrer-piece-jointe-outlook-t55473.html



Sub Store_PJ()

'Declaration
    Dim myItems As Object, myItem As Object, myAttachments As Object, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    'Dim myOlExp As Outlook.Explorer
    'Dim myOlSel As Outlook.Selection
    Dim i As Integer
    Dim nomFichier As String
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As MAPIFolder
    Dim mySearchFolder As MAPIFolder

    'Boîte de dialogue simple pour le chemin de sauvegarde
    'myOrt = InputBox("Destination", "Save Attachments", "P:\Test\SourceFileAM\")
    myOrt = "P:\Test\SourceFileAM\"

    On Error Resume Next

    'Actions sur les objets sélectionnés
    'Set myOlExp = myOlApp.ActiveExplorer
    'Set myOlSel = myOlExp.Selection

Set myNameSpace = myOlApp.GetNamespace("MAPI")
    
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    
    'Test1 = InputBox("Folder", "On est ou", myInbox)
    
    'Set myInbox = olSpace.Folders("isec-iss-controls@ca-cib.com").Store.GetDefaultFolder(olFolderInbox)
    'Test2 = InputBox("Folder", "On est ou", myInbox)
    
    Set mySearchFolder = myInbox.Folders("Test1")

    'boucle
    'For Each myItem In myOlSel
    For Each myItem In mySearchFolder.Items    'boucle sur toutes les éléments du sous-dossier créé dans la boîte de réception
        Set myAttachments = myItem.Attachments
        If myAttachments.Count > 0 Then

            'for all attachments do...
            
            
            
                        For i = 1 To myAttachments.Count
            
                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
                    
            Next i
            
            
            

        End If

    Next

    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    'Set myOlExp = Nothing
    'Set myOlSel = Nothing
    Set myNameSpace = Nothing
    Set myInbox = Nothing
    Set mySearchFolder = Nothing

End Sub




Sub ResolveName()
    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myRecipient As Outlook.Recipient
    Dim CalendarFolder As Outlook.MAPIFolder
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myRecipient = myNameSpace.CreateRecipient("Baptiste George")
    myRecipient.Resolve
    If myRecipient.Resolved Then
        Call ShowCalendar(myNameSpace, myRecipient)
    End If
End Sub
 
Sub ShowCalendar(myNameSpace, myRecipient)
    Dim CalendarFolder As Outlook.MAPIFolder
    Set CalendarFolder = _
        myNameSpace.GetSharedDefaultFolder _
        (myRecipient, olFolderCalendar)
    CalendarFolder.Display
End Sub




Sub Test()
'https://www.developpez.net/forums/d704148/logiciels/microsoft-office/outlook/vba-outlook/execution-d-macro-boite-generique/

            'Déclaration des Objets
            Dim monApply As Outlook.Application
            Dim monMail As Outlook.MailItem
            Dim monNSpace As Outlook.NameSpace
            Dim fldDossier As Outlook.MAPIFolder
            Dim fldDossierTest As Outlook.MAPIFolder
            Dim pJointe As Attachment
 
            Set monApply = Outlook.Application  'Application outlook
            Set monNSpace = monApply.GetNamespace("MAPI")   'Banque MAPI
            Set maBoiteGenerique = monNSpace.CreateRecipient("sec-iss-controls@ca-cib.com") 'isec-iss-controls@ca-cib.com 'ISEC-ISS-Controls
            'Set fldElementSupprime = monNSpace.GetDefaultFolder(olFolderDeletedItems)
 
 'Test1 = InputBox("Folder", "On est ou", maBoiteGenerique)
 
            maBoiteGenerique.Resolve
 
    If maBoiteGenerique.Resolved Then
 
            'Set fldDossierTest = monNSpace.GetSharedDefaultFolder(maBoiteGenerique, olInbox)
            'Set fldDossier = fldDossierTest.Folders("Boîte de réception_INDIC JOUR")
            Set fldDossier = monNSpace.GetSharedDefaultFolder(maBoiteGenerique, olFolderInbox) '.Parent.Folders("Test")
'Call Store_PJ

    End If


End Sub













'Macro Standard
'https://forum.excel-pratique.com/excel/macro-enregistrer-piece-jointe-outlook-t55473.html

Sub PJ()

'Declaration
    Dim myItems As Object, myItem As Object, myAttachments As Object, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    'Dim myOlExp As Outlook.Explorer
    'Dim myOlSel As Outlook.Selection
    Dim i As Integer
    Dim nomFichier As String
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As MAPIFolder
    Dim mySearchFolder As MAPIFolder

    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination", "Save Attachments", "\\192.168.4.1\tresorerie\COMMUN\REPORTING\Macros Tréso\Positions comptes bancaires Filiales étrangères\")

    On Error Resume Next

    'Actions sur les objets sélectionnés
    'Set myOlExp = myOlApp.ActiveExplorer
    'Set myOlSel = myOlExp.Selection

    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set mySearchFolder = myInbox.Folders("Le_nom_de_ton_dossier")

    'boucle
    'For Each myItem In myOlSel
    For Each myItem In mySearchFolder.Items    'boucle sur toutes les éléments du sous-dossier créé dans la boîte de réception
        Set myAttachments = myItem.Attachments
        If myAttachments.Count > 0 Then

            'for all attachments do...
            For i = 1 To myAttachments.Count

                'teste le mail de l'émetteur
                Select Case myItem.SenderEmailAddress
                Case "......@.....ch": nomFichier = "CH - Tréso.xls"
                Case ".......@shp.ie": nomFichier = "IE - Tréso.xls"
                Case "........@......net": nomFichier = "DE - Tréso.xls"
                Case ".......@........aero": nomFichier = "CG CPTS - Tréso.xls"
                Case "...........@.......aero": nomFichier = "CG HANDLING - Tréso.xls"
                Case "...........@........com": nomFichier = "ES - Tréso.xls"
                Case "...........@..........com": nomFichier = "US - Tréso.xls"
                End Select

                'save them to destination
                '                myAttachments(i).SaveAsFile myOrt & _
                                 '                                            myAttachments(i).DisplayName
                myAttachments(i).SaveAsFile myOrt & _
                                            nomFichier
                myItem.Body = myItem.Body & _
                              "File: " & myOrt & _
                              myAttachments(i).DisplayName & vbCrLf

            Next i

        End If

    Next

    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    'Set myOlExp = Nothing
    'Set myOlSel = Nothing
    Set myNameSpace = Nothing
    Set myInbox = Nothing
    Set mySearchFolder = Nothing

End Sub



 

'Module8

'https://www.developpez.net/forums/d1429269/logiciels/microsoft-office/outlook/vba-outlook/extraction-contenu-mail-date-destinaire-expediteur/
'Pour la recertification... On sauvegarde les emails en .msg sur Folder

Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
 
    If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
 

    'Extraction et formatage de la date
    Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
    Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
    Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
    Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
    SenderEmail = objCurrentMessage.Sender.GetExchangeUser.PrimarySmtpAddress
    
    'Ici on construit le nom du fichier qui sera créé
    'NomExport = Annee & Mois & Jour & Heure & " " & objCurrentMessage.Subject & "-" & objCurrentMessage.SenderName
    'NomExport = objCurrentMessage.SenderName & ";" & Annee & "-" & Mois & "-" & Jour & ";" & objCurrentMessage.Subject
    NomExport = SenderEmail & ";" & Annee & "-" & Mois & "-" & Jour & ";" & objCurrentMessage.Subject


    'Ici on défini le répertoire où l'enregistrer
    repertoire = "\\smb15-nas1.par.emea.cib\ISS_DATA\05 - Controls\I3C\2020\Task #6 - Recertification campaign\01 - Préparation\Baptiste\Emails Retour\"
    'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
 
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", " "), "/", " "), ":", ""), "*", " "), "?", " "), "<", " "), ">", " "), "|", " "), ".", " "), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
    'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
    n = 1
    MemPath = PathNomExport
    'MsgBox MemPath
    While Dir(PathNomExport) <> ""
        MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
        PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
        n = n + 1
 
    Wend
    objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
 
End Sub
 
Sub LanceSurOuvert()
    sav_mail_as_msg
End Sub
 
 
Sub LanceSurSelection()
    Dim MonOutlook As Outlook.Application
    Dim LeMail As Object
    Dim LesMails As Outlook.Selection
    Set MonOutlook = Outlook.Application
 
    Set LesMails = MonOutlook.ActiveExplorer.Selection
 
    For Each LeMail In LesMails
        sav_mail_as_msg LeMail
    Next LeMail
 
    Set LesMails = Nothing
    MsgBox "Fin de traitement"
End Sub



 

'Module9

Sub ExtractEmail()
'https://social.msdn.microsoft.com/Forums/en-US/527ccc34-1d7e-48f2-9b8f-8d69497c08a3/outlook-2003-vba-code-to-extract-email-addresses?forum=isvvba

Dim OlApp As Outlook.Application

Dim Inbox As Outlook.MAPIFolder

Dim InboxItems As Outlook.Items

Dim Mailobject As Object

Dim email As String

Set OlApp = CreateObject("Outlook.Application")

Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)

Set InboxItems = Inbox.Items




' Create Text File

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile("P:\_email_addresses.txt", True)


' loop to read email address from mail items.

For Each Mailobject In InboxItems

   'Email = Mailobject.To
   'Email = Mailobject.SenderEmailAddress
   'Email = ObjSelectedItem.Sender.GetExchangeUser.PrimarySmtpAddress
   
   email = Mailobject.Sender.GetExchangeUser.PrimarySmtpAddress

   a.WriteLine (email)

Next


Set OlApp = Nothing

Set Inbox = Nothing

Set InboxItems = Nothing

Set Mailobject = Nothing


a.Close

End Sub






 
Public Sub DisplaySenderDetails()
 Dim Explorer As Outlook.Explorer
 Dim CurrentItem As Object
 Dim Sender As Outlook.AddressEntry
 Dim Contact As Outlook.ContactItem
 
 Set Explorer = Application.ActiveExplorer
 
 ' Check whether any item is selected in the current folder.
 If Explorer.Selection.Count Then
 
 ' Get the first selected item.
 Set CurrentItem = Explorer.Selection(1)
 
 ' Check for the type of the selected item as only the
 ' MailItem object has the Sender property.
 If CurrentItem.Class = olMail Then
 Set Sender = CurrentItem.Sender
 
 ' There is no sender if the item has not been sent yet.
 If Sender Is Nothing Then
 MsgBox "There's no sender for the current email", vbInformation
 Exit Sub
 End If
 
 Set Contact = Sender.GetContact
 
 If Not Contact Is Nothing Then
 ' The sender is stored in the contacts folder,
 ' so the contact item can be displayed.
 Contact.Display
 
 Else
 ' If the contact cannot be found, display the
 ' address entry in the properties dialog box.
 Sender.Details 0
 End If
 End If
 End If
End Sub






Public Sub GetCurrentItem()
'https://stackoverflow.com/questions/24361726/how-can-i-get-the-sender-email-address-using-outlook-mailitem-in-vb-net
    On Error Resume Next
    Set ObjSelectedItem = Outlook.ActiveExplorer.Selection.Item(1)
    If TypeName(ObjSelectedItem) = "MailItem" Then
        If ObjSelectedItem.SenderEmailType = "EX" Then
            MsgBox (ObjSelectedItem.Sender.GetExchangeUser.PrimarySmtpAddress)
        Else
            MsgBox (ObjSelectedItem.SenderEmailAddress)
        End If
    Else
        MsgBox ("No items selected (OR) Selected item not a MailItem.")
    End If
    Set ObjSelectedItem = Nothing
End Sub



 

'Module10

Public Sub Extract_Email_Sender_From_Folder_On_SharedOutlook()
'https://stackoverrun.com/fr/q/9611767

Dim myItems As Object, myItem As Object, myAttachments As Object, myAttachment As Object
Dim myOrt As String
Dim i As Integer

       Dim olNameSpace As Outlook.NameSpace
       Dim olRec As Outlook.Recipient
       Dim olFolder As Outlook.Folder
       Dim mySearchFolder As MAPIFolder
       Dim mySearchFolder1 As MAPIFolder
       
       Dim Mailobject As Object
       
    
              
    'Boîte de dialogue simple pour le chemin de sauvegarde
    'myOrt = InputBox("Destination", "Save Attachments", "P:\Test\SourceFileAM\")
    'myOrt = "P:\Test\Outlook\"
     myOrt = "\\smb15-nas1.par.emea.cib\ISS_DATA\08 - I3C\91 - Controles Pulse\MOVIS PULSE EMEA Connections out of biz hours\SourceFileAM\"

    On Error Resume Next
    

       Set olNameSpace = Application.GetNamespace("MAPI")
       'Set olRec = olNameSpace.CreateRecipient("baptiste.george-prestataire@ca-cib.com") '// Owner's email address
       Set olRec = olNameSpace.CreateRecipient("isec-iss-controls@ca-cib.com") '// Owner's email address

       Set olFolder = olNameSpace.GetSharedDefaultFolder(olRec, olFolderInbox)
       ' MsgBox olRec.Name '// Owner Name
      'MsgBox olFolder.Name
           
       
       'Set mySearchFolder = olFolder.Folders("RemoteLogs")
       Set mySearchFolder = olFolder.Folders("23 - Recertification")
              'Set mySearchFolder = olFolder.Folders("Revocation")
       Set mySearchFolder1 = mySearchFolder.Folders("Lot5 (traité)")
       
       'MsgBox mySearchFolder.Name ' >> OK
       
       
    Set InboxItems = mySearchFolder1.Items
    'Set InboxItems = mySearchFolder.Items
              
              
              
  ' Create Text File

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile("P:\_email_addresses.txt", True)


' loop to read email address from mail items.

For Each Mailobject In InboxItems

   'Email = Mailobject.To
   'Email = Mailobject.SenderEmailAddress
   'Email = ObjSelectedItem.Sender.GetExchangeUser.PrimarySmtpAddress
   
    Annee = Mid(Mailobject.CreationTime, 7, 4)
    Mois = Mid(Mailobject.CreationTime, 4, 2)
    Jour = Mid(Mailobject.CreationTime, 1, 2)
    Heure = Mid(Mailobject.CreationTime, 12, 5)
    
   Lot = "Lot5;"
   email = Mailobject.Sender.GetExchangeUser.PrimarySmtpAddress
   'email = Mailobject.To
   



   a.WriteLine (email & ";1;" & Lot & Annee & "-" & Mois & "-" & Jour & " : " & Heure & ";" & Mailobject.Subject)

Next


Set OlApp = Nothing

Set Inbox = Nothing

Set InboxItems = Nothing

Set Mailobject = Nothing


a.Close
              
         


       'olFolder.Display '// Open Inbox
End Sub

bottom of page