Save E mail using different path.

Status
Not open for further replies.
Frédéric

Frédéric

Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
Dear Developpers,

Wonderful website full of information.
I'm currently looking for a way to save email. Problem : Path will be change regarding both information, body and subject.
Each time a mail income in my Inbox, I would like to create a record of this mail on the network but path of recording will depends on a keyword placed in the body and name of the recorded email will depends on words in subject...

i already used this code :

Code: 
Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String
    Dim strFolderpath As String
  
    enviro = CStr(Environ("USERPROFILE"))
'Defaults to Documents folder
' get the function at http://slipstick.me/u1a2d

strFolderpath = BrowseForFolder(enviro & "\documents\")
   
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
    
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
  
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, " - hh.nn.ss", _
    vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
      
  sPath = strFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMsg
   
  End If
  Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)

End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
 
Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
Exit Function
 
Invalid:
BrowseForFolder = False
End Function

I actually don't need the Browse for Folder part... I would like Outlook decide by itself the path it will be used...Any idea ?

Thanks

Fred
 
If you don't need to browse, replace this with the path -
strFolderpath = "C\newpathhere"

As long as the path is almost always identical, and the keyword in the message is the folder name that changes, you could use something like "C:\path\" & keyword & "\" if they are totally different, you'll need to use either select case or an array to set the path. Using Arrays in Outlook macros
 
Thanks You Diane

I will explore this option

Thanks !

Fred
 
Hello Diane,

I would like rather to create one macro for each rules i made.
I still use this Macro

Code: 
Public Sub SaveMessageAsMsg()

    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String
    Dim strFolderpath As String
 
    enviro = CStr(Environ("USERPROFILE"))
 
strFolderpath = BrowseForFolder(enviro & "\documents\")
  
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
   
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, " - hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
     
  sPath = strFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMsg
  
  End If
  Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)

End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
Exit Function

Invalid:
BrowseForFolder = False
End Function

But i would like to avoid the browse to folder part. I'm looking for a way to change this macro. I don't need to select mail i wish to save and i don't need to tell Outlook where i wish to save. I just need Outlook to save regarding rules i gave to it ;)

Any idea ?

Thanks
 
BTW, if you are using more than one rule and more than one path, you could have a lot of stub macros that set the value for strFolderpath (and remove the dim and set for omail, and the dim and set for the folder path) then call the SaveMessageAsMsg and pass the path.

Put this at the top of the module, outside of any macro:
Dim strFolderpath As String

and use this in the rule -
public sub rule1(item as outlook.mailitem)
strfolderpath = "c:\the path"
SaveMessageAsMsg oMail
end sub

rename the macro this:
Public Sub SaveMessageAsMsg(oMail as outlook.mailitem)
 
Diane Poremsky said:
Replace this line:
strFolderpath = BrowseForFolder(enviro & "\documents\")

with your path -
strFolderpath = enviro & "\documents\"
Click to expand...

Thanks Diane

What do you mean ?

Does it following ok ?

Public Sub SaveMessageAsMsg(oMail as outlook.mailitem)

Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim strFolderpath As String

enviro = CStr(Environ("USERPROFILE"))

strFolderpath = "H:\Control\07.delegates\02.Admin\Incoming Mails\Globes"
strFolderpath = enviro & "\documents\"

For Each objItem In ActiveExplorer.Selection
.......
...
..
Click to expand...
 
you don't need both & the second one is the one outlook uses. If the first path is the path you want to use, delete the second line.
strFolderpath = "H:\Control\07.delegates\02.Admin\Incoming Mails\Globes"
strFolderpath = enviro & "\documents\"
 
Ok Diane

Thank you very much

So if i summarize, i put this code in a module :

Code: 
Dim strFolderpath As String
Public Sub ruleGlobes(item As Outlook.MailItem)

strFolderpath = "H:\Function\07.delegates\02.Admin\Incoming Mails\Globes"
SaveGlobes oMail
End Sub

Public Sub SaveGlobes()

     Dim oMail As Outlook.MailItem
     Dim objItem As Object
     Dim sPath As String
     Dim dtDate As Date
     Dim sName As String
     Dim enviro As String
     Dim strFolderpath As String
 
    strFolderpath = "H:\Function\07.delegates\02.Admin\Incoming Mails\Globes"
 
    For Each objItem In ActiveExplorer.Selection
    If objItem.MessageClass = "IPM.Note" Then
     Set oMail = objItem
  
   sName = oMail.Subject
   ReplaceCharsForFileName sName, "-"

   dtDate = oMail.ReceivedTime
   sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, " - hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
    
   sPath = strFolderpath & "\"
   Debug.Print sPath & sName
   oMail.SaveAs sPath & sName, olMsg
 
   End If
   Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
   sName = Replace(sName, "'", sChr)
   sName = Replace(sName, "*", sChr)
   sName = Replace(sName, "/", sChr)
   sName = Replace(sName, "\", sChr)
   sName = Replace(sName, ":", sChr)
   sName = Replace(sName, "?", sChr)
   sName = Replace(sName, Chr(34), sChr)
   sName = Replace(sName, "<", sChr)
   sName = Replace(sName, ">", sChr)
   sName = Replace(sName, "|", sChr)

End Sub

then, i create as module as i need without forgeting to update "Globes" and path for others module, and finaly i add Outlook rules the "run a script" function for each of modules/rules...

That's right ?

I just have doubts regarding this line :

For Each objItem In ActiveExplorer.Selection

Because i wish a save for New Email, not for selected.

Fred
 
you need to remove the dim/set for omail and the for each /next lines.

if by this >> I would like rather to create one macro for each rules i made.

you have more than one rule and need to use a different path with each rule, having the macros split will allow you to do it with the least amount of code.

Public Sub rule1(item As Outlook.MailItem)
strFolderpath = "H:\Function\07.delegates\02.Admin\Incoming Mails\Globes"
SaveGlobes oMail
End Sub

Public Sub rule2(item As Outlook.MailItem)
strFolderpath = "H:\Function\07.delegates\02.Admin\Incoming Mails\somethingelse"
SaveGlobes oMail
End Sub



if you are using the same script, it's less useful to break it in two, but can speed up rules because it hands off to another macro.

This should work -

Code: 
Dim strFolderpath As String
Public Sub ruleGlobes(item As Outlook.MailItem)

strFolderpath = "H:\Function\07.delegates\02.Admin\Incoming Mails\Globes"
SaveGlobes oMail
End Sub

Public Sub SaveGlobes(oMail as outlook.mailitem)
     Dim sPath As String
     Dim dtDate As Date
     Dim sName As String
   sName = oMail.Subject
   ReplaceCharsForFileName sName, "-"

   dtDate = oMail.ReceivedTime
   sName = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, " - hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
   
   sPath = strFolderpath & "\"
   Debug.Print sPath & sName
   oMail.SaveAs sPath & sName, olMsg
   End If
   Next

End Sub
 
Dear Diane,

Here is my code. Whole lines are pasted in "ThisOutlookSession" and i have no other things in the project (no Module, No Class...)

First part is "regle part" (Means Rules Part). I use it for Outlook Rules. For example when an incoming mail with "Flobes" comes, rule runs in order to move .msg in sub-folders and rule is also running a script. In this case, "regle_Flobes" Please note path is longer than showed and replaced by "XXX"

This macro is currently no able to save files... I'm sure i'm not far from. Have you got an idea ?

Thanks very much !

Code: 
Sub regle_Tigaga(Mail As Outlook.MailItem)
      Call SavAs_mail_as_msg(oMail, "H:\XXX\Incoming Mails\Tigaga\")
End Sub

Sub regle_Flobes(Mail As Outlook.MailItem)
      Call SavAs_mail_as_msg(oMail, "H:\XXX\Incoming Mails\Flobes\")
End Sub

Sub regle_Venturion(Mail As Outlook.MailItem)
      Call SavAs_mail_as_msg(oMail, "H:\H:\XXX\Incoming Mails\Venturion\")
End Sub

Sub regle_Bultitest(Mail As Outlook.MailItem)
      Call SavAs_mail_as_msg(oMail, "H:\XXX\Incoming Mails\Bultitest\")
End Sub

Sub regle_Neregord(Mail As Outlook.MailItem)
     Call SavAs_mail_as_msg(oMail, "H:\XXX\Incoming Mails\Neregord\")
End Sub
-------------------------------------------------------------------------------------------------------------------------------------
Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : SavAs_mail_as_msg
' Author  : Oliv
  
  dtDate = MyMail.ReceivedTime
  mlSubj = MyMail.Subject
  NomExport = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & " - " & Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & mlSubj
 
  If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"

  Call waaps_creedir(repertoire)
 
  PathNomExport = repertoire & "Email" & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
  NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
  n = 1
  MemPath = PathNomExport
  
  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
  MyMail.SaveAs PathNomExport, OlSaveAsType.olMsg

End Sub
-----------------------------------------------------------------------------------------
Function waaps_creedir(lerep As String) As Boolean

  Dim FSO As FileSystemObject, i As Integer, retour As Boolean
  Dim rp As String, r
 
  Set FSO = CreateObject("Scripting.filesystemobject")
 
  rp = Replace(lerep, "\", "/")
  rp = Replace(rp, "//", "/")
  rep = Split(rp, "/")
  r = REP_TOP
  retour = True
  For i = 0 To UBound(rep)
  If (rep(i) <> "") Then
  r = r & rep(i) & "\"
  If (Not FSO.FolderExists(r)) Then
  FSO.CreateFolder (CStr(r))
  If (Not FSO.FolderExists(r)) Then retour = False
  End If
  End If
  Next
  Set FSO = Nothing
  waaps_creedir = retour
End Function
 
ok... using this to tyest it on the selected message
Code: 
Sub RunScript()
Dim objApp As Outlook.Application
Dim objItem As MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)
'macro name you want to run goes here
regle_Tigaga objItem
End Sub


And this code - (i got an error on oMail and changed it to Mail)
Code: 
Sub regle_Tigaga(Mail As Outlook.MailItem)
      MsgBox Mail.Subject
      Call SavAs_mail_as_msg(Mail, "C:\Users\drcp\Documents\test\")
End Sub

It worked when i removed this line -
'Call waaps_creedir(repertoire)

This is the filename that was saved:
Email20160401 - 002001 - Exchange Messaging Outlook Meeting Request Tracking.msg
 
Ok Diane, so if i understand, in "ThisOutlookSession" i paste

Code: 
Sub RunScript()
Dim objApp As Outlook.Application
Dim objItem As MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)
'macro name you want to run goes here
regle_Tigaga objItem
End Sub

and

Code: 
Sub regle_Tigaga(Mail As Outlook.MailItem)
      MsgBox Mail.Subject
      Call SavAs_mail_as_msg(Mail, "C:\Users\drcp\Documents\test\")
End Sub

and

Code: 
Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : SavAs_mail_as_msg
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
' exemple repertoire = "c:\mail\"
    'Ici on construit le nom du fichier qui sera créé
 
    dtDate = MyMail.ReceivedTime
    mlSubj = MyMail.Subject
    NomExport = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & " - " & Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & mlSubj
    'Ici on vérifie le répertoire où l'enregistrer
    If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & "Email" & 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
    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
    MyMail.SaveAs PathNomExport, OlSaveAsType.olMsg
End Sub

without pasting the "waaps_creedir function"
and i assign "rule_Tigaga" as script in the Tigaga Outlook rule setting.

Right ?

Thanks!

Fred
 
The first macro (RunScript) is used to trigger the run a script macro manually so you don't have to send test messages. Paste it at the bottom of ThisOutlookSession or in a module - run a scripts can either be in a module or in thisoutlooksession (and sometimes work better in a module).

Add a msgbox to the script the rule calls, so you know if it is being triggered (after the first time, you'll want to remove it - it's annoying :)). Select a message, run the RunScript macro - it triggers the script, pops up the message box and calls the savas_mail macro.
 
Dear Diane,

Thank you to spend time for explaination. I finally found a way (with many help of Diane and Oliv').
This code allows to set scripts to Outlook rules (Règle 1, Régle 2....) and ask Outlook to save incoming mails (.msg) in différent paths, according mail body or subject (depending what you defined in Outlook rule).

Main idea of most of my saving rules are :

Apply this rule after the message arrives
from "sender"
and sent to "recipient"
and with "xxxxxx" in the body
move it to "yyyyyyy" folder
and run Project1.rule_Tigaga

So when a mail incomes, regarding words in body, Outlook will execute rule, which by itself execute VBA Code.

The code :

Code: 
'-------------------------------------------------Les scripts devant être associés aux règles Outlook----------------------------
'----------------------Règle 1-------------------------------------------------------------------------------------------------------
Sub rule_Tigaga(Mail As Outlook.MailItem)
    FundType = "MC - Tigaga"
    Call SavMsgFundType(Mail, "H:\XXX\Incoming Mails\MC - Tigaga\", FundType)
End Sub
'----------------------Règle 2-------------------------------------------------------------------------------------------------------
Sub rule_Flobes(Mail As Outlook.MailItem)
    FundType = "MC - Flobes"
    Call SavMsgFundType(Mail, "H:\XXX\Incoming Mails\MC - Flobes\", FundType)
End Sub
'----------------------Règle 3-------------------------------------------------------------------------------------------------------
Sub rule_Venturion(Mail As Outlook.MailItem)
    FundType = "MC - Venturion"
    Call SavMsgFundType(Mail, "H:\XXX\MC - Venturion\", FundType)
End Sub
'----------------------Règle 4-------------------------------------------------------------------------------------------------------
Sub rule_MI(Mail As Outlook.MailItem)
    FundType = "MI"
    Call SavMsgFundType(Mail, "H:\XXX\Incoming Mails\MI\", FundType)
End Sub
'----------------------Règle 5-------------------------------------------------------------------------------------------------------
Sub rule_Alter(Mail As Outlook.MailItem)
    FundType = "MI - Alter"
    Call SavMsgFundType(Mail, "H:\XXX\Incoming Mails\MI - Alter\", FundType)
End Sub
'----------------------Règle 6-------------------------------------------------------------------------------------------------------
Sub rule_HF(Mail As Outlook.MailItem)
    FundType = "Neregord Funds"
    Call SavMsgFundType(Mail, "H:\XXX\Incoming Mails\HF\", FundType)
End Sub
'-------------------------------------------------Les macros étant appelées par les scripts---------------------------------------
'----------------------Macro 1-------------------------------------------------------------------------------------------------------
Sub SavMsgFundType(MyMail As Outlook.MailItem, repertoire, FundType)
'Construction du nom de fichier sauvegardé
    dtDate = MyMail.ReceivedTime
    mlSubj = MyMail.subject
    NomExport = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & " - " & Format(dtDate, "hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & FundType & " - " & mlSubj
    'Ici on vérifie le répertoire où l'enregistrer
    If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
    '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
    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
    MyMail.SaveAs PathNomExport, OlSaveAsType.olMSG
End Sub

Thanks Diana !

Fred
 
Not to break what is working but.... it's recommended that run a script rules only contain conditions, that all actions are in the script. Adding the move to action to the script isn't difficult. Additionally, it would be possible to move either recipient or sender to the script and using just one rule, one script. (Putting both in the script would mean you'd process all mail with the script - which could be slow if you get a lot of mail.)

Apply this rule after the message arrives
from "sender"
and sent to "recipient"
and with "xxxxxx" in the body
move it to "yyyyyyy" folder
and run Project1.rule_Tigaga
Click to expand...


This is probably not the best example for your needs, but it shows one way to do it: Outlook AutoReplies: One script, many responses

In your case, I would probably use a Select Case
Select Case olmail.senderemailaddress
Case "a@b.com"
FundType = "MC - Tigaga"
' if the path is always the same down to the last folder, you could just have the folder name here
' if the last folder is always the fund type, you don't this at all.
repertoire = "H:\XXX\Incoming Mails\MC - Tigaga\"

Case "b@c.com"
FundType = "MI"
repertoire = "H:\XXX\Incoming Mails\MI\"

end select

if you just needed the fund type variable, you could set the path in the main macro like this:
repertoire = "H:\XXX\Incoming Mails\" & FundType & "\"
 
This is my version - the rule is running on all messages in my test mailbox (because it's a test mailbox and gets very little mail) and checking the sender address in the macro.

The beauty of this is one rule, one macro. You can easily add more funds as case statements without adding more rules.

If this part changes with each fundtype: H:\XXX\Incoming Mails, then the repertoire line goes in each case.

Code: 
Sub SavMsgFundType(Mail As Outlook.MailItem)
'Construction du nom de fichier sauvegardé
    dtDate = Mail.ReceivedTime
    mlSubj = Mail.Subject
    NomExport = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & " - " & Format(dtDate, "hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & FundType & " - " & mlSubj
    'Ici on vérifie le répertoire où l'enregistrer
   
Select Case Mail.SenderEmailAddress
Case "alias1@slipstick.com"
FundType = "MC - Tigaga"

Case "alias2@cdolive.com"
FundType = "MI"

Case "alias3@slipstick.com"
FundType = "MC"

End Select
   
   
    repertoire = "C:\Users\Diane\Documents\Macro Test\" & FundType & "\"
   
   
    '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
    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
    Mail.SaveAs PathNomExport, OlSaveAsType.olMSG
End Sub
 
oops... i forgot the move message lines. (the rule can handle the words in the body part or it can be added to the macro.)

Add this at the end - it assumes the folder name = the fund name and it's under the Inbox (but it can use any folder, we'd just need to set the path). If the folder name is not the fund name or the path varies with each fund, set the folder name variable in the case statement. If it's always the same folder, use objFolder.Folders("folder name")

Set objFolder = Session.GetDefaultFolder(olFolderInbox)
Set objDestFolder = objFolder.Folders(FundType)
Mail.Move objDestFolder



Code: 
Sub SavMsgFundType(Mail As Outlook.MailItem)
'Construction du nom de fichier sauvegardé
    dtDate = Mail.ReceivedTime
    mlSubj = Mail.Subject
    NomExport = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem) & " - " & Format(dtDate, "hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem) & " - " & FundType & " - " & mlSubj
    'Ici on vérifie le répertoire où l'enregistrer


Select Case Mail.SenderEmailAddress
Case "alias1@slipstick.com"
FundType = "MC - Tigaga"

Case "alias2@cdolive.com"
FundType = "MI"

Case "alias3@slipstick.com"
FundType = "MC"

End Select
  
    repertoire = "C:\Users\Diane\Documents\Macro Test\" & FundType & "\"
  
    '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
    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
    Mail.SaveAs PathNomExport, OlSaveAsType.olMSG
  
'Dim objFolder As Outlook.Folder
'Dim objDestFolder As Outlook.Folder
Set objFolder = Session.GetDefaultFolder(olFolderInbox)
Set objDestFolder = objFolder.Folders(FundType)
Mail.Move objDestFolder

End Sub
 
Status
Not open for further replies.
< Question: Is there a rule that will save email in Windows Explorer | Best practice for catching mailitem.events >
Similar threads
Thread starter Title Forum Replies Date
J Save E-mail attachments in a specific folder Outlook VBA and Custom Forms 0
L Save Mail Message to new folder created automatically Outlook VBA and Custom Forms 1
P How to save sent mail and forward it the next day Exchange Server Administration 3
D VBA Script (Ask to where to save send mail) Outlook VBA and Custom Forms 1
K Ask about a simple script about save a incoming mail as file on local PC Outlook VBA and Custom Forms 3
F CAN'T SAVE OUTLOOK 2010 E-MAIL TEMPLATE (.oft) Using Outlook 1
M how to save incoming mail in TRUE csv format Outlook VBA and Custom Forms 1
B Save e-mail to .msg file Outlook VBA and Custom Forms 4
S how to disable security message in save attachments macro "A programis trying to access e-mail addre Outlook VBA and Custom Forms 5
M Save as Adobe PDF misses inline graphics Using Outlook 0
Sandgroper48 Save vbaProject Outlook VBA and Custom Forms 2
J Outlook 2019 Pick the Folder Location to save send emails Outlook VBA and Custom Forms 0
boblewis Technical Issue with Custom Form - Save to Drafts Not Syncing Outlook VBA and Custom Forms 1
Rob Can't save MailItem because the message changed in .pst file Outlook VBA and Custom Forms 0
G Save emails as msg file from Outlook Web AddIn (Office JS) Outlook VBA and Custom Forms 0
E Outlook 365 Save Selected Email Message as .msg File - oMail.Delete not working when SEARCH Outlook VBA and Custom Forms 0
E Save Selected Email Message as .msg File - digitally sign email doesn't works Outlook VBA and Custom Forms 1
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
C Outlook 365 Copy/Save Emails in Folder Outside Outlook to Show Date Sender Recipient Subject in Header Using Outlook 0
W Create a Quick Step or VBA to SAVE AS PDF in G:|Data|Client File Outlook VBA and Custom Forms 1
C Outlook (desktop app for Microsoft365) restarts every time I save my VBA? Using Outlook 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
N VBA Macro To Save Emails Outlook VBA and Custom Forms 1
N Save emails within a certain date range to network drive Outlook VBA and Custom Forms 0
T Outlook 365 Move newly created tasks automatically on save. Outlook VBA and Custom Forms 1
G Save attachment run a script rule Outlook VBA and Custom Forms 0
N Save Selected Email Message as .msg File Outlook VBA and Custom Forms 12
G Save and Rename Outlook Email Attachments Outlook VBA and Custom Forms 0
G VBA to save selected Outlook msg with new name in selected network Windows folder Outlook VBA and Custom Forms 1
D Outlook 2016 64bit, Cannot Save in 'HTML', format Using Outlook 1
N Save selected messages VBA does not save replies and/or messages that contain : in subject Outlook VBA and Custom Forms 1
L Macro to add Date & Time etc to "drag to save" e-mails Outlook VBA and Custom Forms 17
S save attachment with date & time mentioned inside the file Outlook VBA and Custom Forms 0
S Add VBA save code Using Outlook 0
A Edit attachment Save and Reply Outlook VBA and Custom Forms 0
S Outlook (2016 32bit; Gmail IMAP) - Save sent message to Outllook Folder Outlook VBA and Custom Forms 0
P Outlook pst file is too huge with POP3. How to save more space? Using Outlook 4
D Prevent popup of "Do you want to save changes?" when closing after opening an appointment to view Outlook VBA and Custom Forms 2
A Unable to save recurring Meeting to Documents folder due to error Using Outlook 2
M Outlook 2013 Script Assistance - Save Opened Link with Subject Added Outlook VBA and Custom Forms 1
R Use an ItemAdd to Save Attachments on Arrival Outlook VBA and Custom Forms 0
W Outlook Calendar does not save view any longer! Using Outlook 3
S automate save the .xlxs file to share Network Using Outlook 1
S save email from excel Outlook VBA and Custom Forms 1
Y Open and Save Hyperlink Files in multiple emails Outlook VBA and Custom Forms 9
9 Outlook 2016 How to save an Outlook attachment to a specific folder then delete the email it came from? Using Outlook 1
O Save attachments using hotkey without changing attributes Outlook VBA and Custom Forms 1
geofferyh Cannot get Macro to SAVE more than one message attachment??? Outlook VBA and Custom Forms 5
N Open & Save VBAProject.Otm using VBA Code Outlook VBA and Custom Forms 1
R VBA | Chosing path to save file Outlook VBA and Custom Forms 1

Similar threads

Back
Top