I'm trying to save selected messages in Outlook on a tempfolder on my Desktop.
Public Sub SaveMessageAsMsg1()
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
enviro = CStr(Environ("USERPROFILE"))
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, "yyyymmdd", vbUseSystemDayOfWeek,vbUseSystem) & Format(dtDate, "-hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = "C:\Users\XBBLC1C\Desktop\TempEmail\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Some of the messages are already archived in Enterprise vault and while saving those messages objItem.MessageClass generates the value IPM.Note.EnterpriseVault.Shortcut.
To accommodate this I tried an asterisk with IPM.Note in the above code.
I don't know exactly what you're trying to do, but the line:
If objItem.MessageClass = "IPM.Note*" Then
is likely not going to do the comparison you are hoping for. While '*' is a wildcard character in certain circumstances, it isn't for a string comparison like this.
I'd suggest trying:
If inStr(objItem.MessageClass, "IPM.Note") <> 0 Then
which will be true if "IPM.Note" is anywhere in the message class
OR
If InStr(objItem.MessageClass, "IPM.Note") = 1 Then
which will be true if "IPM.Note" is at the beginning of the message class.
Similarly you could use
If objItem.MessageClass like "IPM.Note*" Then
if you want something closer to what you were originally writing.
You can do what OpiesDad suggested and check the MessageClass property, or you can check the MailItem.Class property - for regular MailItem objects, it will be 43 (OlObjectClass.olMail):
If objItem.Class = 43 Then
...
Related
After selecting the email item in Outlook, press ctrl+C and open a folder in Windows Explorer and press ctrl+V act save the email msg file to this folder.
At this time, the saved file name is designated as the subject of the email.
I succeeded in changing the title and saving it, but this method is cumbersome because it saves to a specific folder.
I'm trying to make a similar user experience with ctrl+C/ctrl+V.
How do I copy the email object item to the clipboard in the form of a file?
I tried MSForms.
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 sSender As String
'Dim buf As MSForms.DataObject
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
sSender = oMail.Sender
If InStr(sSender, "/") > 0 Then sSender = Left(sSender, InStr(sSender, "/") - 1)
If InStr(sSender, "(") > 0 Then sSender = Left(sSender, InStr(sSender, "(") - 1)
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "_hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & "_" & sSender & "_" & sName & ".msg"
sPath = enviro & "\Documents\SaveMails\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
I need a macro for Outlook that will do:
Saves the open e-mail as email.msg (including attachments)
Closes the curent e-mail window
Creates a new email, which is read from email.msg (from step 1.)
I did some research on google, but nothing works for me.
This is what i've done so far (the 1. step.. but not working)
Option Explicit
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
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "email"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = enviro & "\Documents\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMsg
'this closes window:
Dim myinspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Set myinspector = Application.ActiveInspector
Set myItem = myinspector.CurrentItem
myItem.Close olSave
End If
Next
End Sub
Option Explicit
Sub SaveCurrentItemAsMsg()
Dim oMail As MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim myItem As MailItem
enviro = CStr(Environ("USERPROFILE"))
Set objItem = ActiveInspector.currentItem
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "email"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = enviro & "\Documents\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMsg
oMail.Close olDiscard
Set oMail = Nothing
Set myItem = Session.OpenSharedItem(sPath & sName)
myItem.Display
End If
End Sub
Sub SaveSelectedMessagesAsMsg()
Dim oMail As MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim myItem As MailItem
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "email"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = enviro & "\Documents\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMsg
Set myItem = Session.OpenSharedItem(sPath & sName)
myItem.Display
End If
Next
End Sub
There are a few sources from which we receive specific emails. The easiest way to categorize them is by mail title or even source email address.
We are trying to automatically save all incoming emails to file, whether it's a TXT or PDF so we can pull up a back up file when there is a problem with the network, email or whatever else is malfunctioning.
I tried to create a macro from a few similar topics;
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
SaveMailAsFile Item ' call sub
End If
End Sub
Public Sub SaveMailAsFile(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim ItemSubject As String
Dim NewName As String
Dim RevdDate As Date
Dim Path As String
Dim Ext As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")
Path = Environ("USERPROFILE") & "\Desktop\Backup Reports\"
ItemSubject = Item.Subject
RevdDate = Item.ReceivedTime
Ext = "txt"
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
If Item.Class = olMail Then
Debug.Print Item.Subject ' Immediate Window
Set SubFolder = Inbox.Folders("Temp") ' <--- Update Fldr Name
ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
& " - " & _
Item.Subject & Ext
ItemSubject = FileNameUnique(Path, ItemSubject, Ext)
Item.SaveAs Path & ItemSubject, olTXT
Item.Move SubFolder
End If
Next
Set olNs = Nothing
Set Inbox = Nothing
Set SubFolder = Nothing
Set Items = Nothing
End Sub
'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FullName) Then
FileExists = True
Else
FileExists = False
End If
Exit Function
End Function
'// If the same file name exist then add (1)
Private Function FileNameUnique(Path As String, _
FileName As String, _
Ext As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(FileName) - (Len(Ext) + 1)
FileName = Left(FileName, lngName)
Do While FileExists(Path & FileName & Chr(46) & Ext) = True
FileName = Left(FileName, lngName) & " (" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = FileName & Chr(46) & Ext
Exit Function
End Function
While I understand that Outlook cache is available even off line some are insisting to have back up files on a physical hard drive.
I know I could manually select those files and create a copy by drag&drop but that is insufficient.
I am aware of
https://www.techhit.com/messagesave/screenshots.html. It would be difficult to have this idea accepted because GDPR blah blah blah.
You could use this code, paste it in the ThisOutlookSession module.
To test this code sample without restarting Outlook, click in the Application_Startup procedure then click Run.
Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
sName = Item.Subject
ReplaceCharsForFileName sName, "_"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
' use My Documents for older Windows.
sPath = enviro & "\Documents\"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End If
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, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
For more information, please refer to this link:
Save all incoming messages to the hard drive
Save outlook mail automatically to a specified folder
I'm doing the following in VBA in Outlook. Upon dragging an Outlook item to a specified folder, I save this Outlook item to my computer (i.e. a filing system).
Private WithEvents Items As Outlook.Items
Private WithEvents Items2 As Outlook.Items
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = Ns.GetDefaultFolder(olFolderInbox).Parent.Folders("Hello").Items
Set Items2 = Ns.GetDefaultFolder(olFolderInbox).Parent.Folders("Bye").Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
sName = Item.Subject
ReplaceCharsForFileName sName, "_"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " - hhnn ", _
vbUseSystemDayOfWeek, vbUseSystem) & "- " & sName & ".msg"
sPath = "Y:\BM_Clientenmap\D\Hello\emails\"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End If
End Sub
Private Sub Items2_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
sName = Item.Subject
ReplaceCharsForFileName sName, "_"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " - hhnn ", _
vbUseSystemDayOfWeek, vbUseSystem) & "- " & sName & ".msg"
sPath = "Y:\BM_Clientenmap\D\Bye\emails\"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End If
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, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
This code saves an Outlook item to the computer in directory sPath (Sub Items/Items2_AddItem), if the user adds a file to the directory specified in the variable Items/Items2 declared at the top.
The problem is it requires me to manually add in VBA which folders VBA should "watch" when an item is added, and where to save these files. As a result, it requires me to write a new Items variable and new Items_ItemAdd sub for every folder I have.
I want to do the following:
Select the folder that should be "watched" for an item added, and the folder to which it should be saved, through user interface in Outlook instead of VBA. Users should select multiple folders (I don't care if they have to select them one at a time), with multiple save folders on the computer.
I want Outlook to remember the choices that the user made upon closing Outlook.
To make it more user friendly, I thought about the following.
User selects folder in Outlook. Code that I found that does this:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
User then selects the folder the item should be saved to on computer. Code that I found that allows you to set a variable to an input filepath:
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0,
enviro & "\Computer\")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Sub
I want the above code to run when the user presses a button in the ribbon to which my macro would be set.
I want Outlook to watch these folders that the user has selected (i.e. what Sub Items_ItemAdd does). This is where I get stuck. I want the choices of the user to be remembered (i.e. so the user doesn't have to select his folders every time he opens Outlook) after Outlook is closed.
Now my questions are as follows:
I imagined one way to make this work is to create a new variable Items(i) and a new Sub Items(i)_ItemAdd directly in the VBA code every time the user selects the folder and save folder. However, I read this is impossible to do in Outlook, unlike in Excel. Is this true? If not: how to create VBA code using VBA in Outlook?
Another way I can imagine is the following. I save the input that the user made to a text file, and I read from the text file and save that to an array. However, I do not know how to use the array in the rest of my code. I do not think it's possible to create a Sub with a variable name, or run a sub with "ItemAdd" 'watcher' included in a for-loop that runs through the array and creates Sub functions based on the index in the Array or something like that.
Hope anyone can help me. Or knows any other ideas on how to make my idea work.
This doesn't address how you collect or store the various folders, but shows how to manage a collection of "watched" folders with separate "save to" paths.
First, create a class to manage each folder:
Option Explicit
Private OlFldr As Folder
Private SavePath As String
Public WithEvents Items As Outlook.Items
'called to set up the object
Public Sub Init(f As Folder, sPath As String)
Set OlFldr = f
Set Items = f.Items
SavePath = sPath
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
'Just a simple message to show what's going on.
'You can add code here to save the item, or you can pass
' arguments to a common sub defined in a regular module
MsgBox "Mail '" & Item.Subject & "' was added to Folder '" & OlFldr.Name & _
"' and will be saved to '" & SavePath & "'"
End If
End Sub
Here's how you'd use that class to set up your watched folders:
Option Explicit
Dim colFolders As Collection '<< holds the clsFolder objects
Private Sub SetupFolderWatches()
'This could be called on application startup, or from the code which collects
' user selections for folders/paths
Dim Ns As Outlook.NameSpace, inboxParent, arrFolders, f, arr
Set Ns = Application.GetNamespace("MAPI")
Set colFolders = New Collection
Set inboxParent = Ns.GetDefaultFolder(olFolderInbox).Parent
'you'd be reading this info from a file or some other storage...
arrFolders = Array("Test1|C:\Test1_Files\", "Test2|C:\Test2_Files\")
For Each f In arrFolders
arr = Split(f, "|")
colFolders.Add GetFolderObject(inboxParent.Folders(arr(0)), CStr(arr(1)))
Next f
End Sub
'"factory" function to create folder objects
Function GetFolderObject(foldr As Folder, sPath As String)
Dim rv As New clsFolder
rv.Init foldr, sPath
Set GetFolderObject = rv
End Function
first of all i'll say that i'm not an expert in coding but i do have a basic understanding.
i have a script that saves all unread mails as txt and marks them as read.
It works fine, but when i set up a rule with it to run every time i get a mail from a specific person it doesn't effect the first mail.
Example: i get a mail, the script runs but doesn't save anything (as long as there is no other mail from the same person and isn't Unread).
then i get a second mail from the same person, the script will run and save the previous mail but not the latest one.
Here a sample of the code:
Public Sub TestEnvMacro()
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objMailbox = objNamespace.Folders("your email goes here")
Set objFolder = objMailbox.Folders("Inbox")
Set colItems = objFolder.Items
Dim NewMsg
Dim dtDate As Date
Dim sName As String
Const OLTXT = 0
Pause (5)
For Each objMessage In colItems.Restrict("[Unread] = True")
If objMessage.UnRead = True Then
Pause (5)
Set NewMsg = objMessage
sName = NewMsg
dtDate = NewMsg.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".txt"
NewMsg.SaveAs "G:\" & sName, OLTXT
NewMsg.UnRead = False
End If
Next
End Sub
I didn't include the pause Sub since it's pretty self explanatory what it does, also i've had a problem with getting the script to show up in the "Rules" so I added this Sub:
Public Sub SaveAsTextMod(msg As MailItem)
Dim strID As String
Dim olNS As NameSpace
Dim olMail As MailItem
strID = msg.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
Call TestEnvMacro
Set olMail = Nothing
Set olNS = Nothing
End Sub
When you create a rule to apply for incoming emails, the mail item is passed as a parameter to the macro sub. There is no need to search for unread emails in Outlook. You just need to define the function with a MailItem parameter do the required actions against that objects.
Public Sub SaveAsTextMod(msg As MailItem)
Dim dtDate As Date
Dim sName As String
dtDate = msg.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & msg.Subject & ".txt"
msg.SaveAs "G:\" & sName, OLTXT
msg.UnRead = False
End Sub
You may find the Getting Started with VBA in Outlook 2010 article helpful.