CRAZYTRADER Forex : MT4 Indicators
'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