Restrict() does not seem to accept a date value when it is specified outside.
Public Sub EBS()
Dim oMail As MailItem
Dim sPath As String
Dim dtDate As Date
Dim dtRecDate As Date
Dim sName As String
Dim oNameSpace As Outlook.NameSpace
Dim oInboxFolder As Outlook.Folder
Dim oSentFolder As Outlook.Folder
Dim i As Long
Set oNameSpace = Application.GetNamespace("MAPI")
Set oInboxFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
Set oSentFolder = oNameSpace.GetDefaultFolder(olFolderSentMail)
dtRecDate = DateAdd("d", -180, Now)
Set setItems = oInboxFolder.Items
Set RestrictedItems = setItems.Restrict("[ReceivedTime] < dtRecDate AND [MessageClass] = 'IPM.Note'")
For i = RestrictedItems.Count To 1 Step -1
Set oMail = RestrictedItems.item(i)
sName = oMail.Subject
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, "_hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "_" & sName & ".msg"
sName = Left(sName, 256)
sPath = "C:\ARCHIVE\OUTLOOK\Inbox\"
Debug.Print dtRecDate
oMail.SaveAs sPath & sName, olMSG
oMail.Delete
Next i
End Sub
The restriction works when, for example, '2014/06/13' is used instead of dtRecDate.
When dtRecDate is used, it does not restrict any item.
Can you please help?
I see the following filter criteria in the code:
"[ReceivedTime] < dtRecDate AND [MessageClass] = 'IPM.Note'"
You can't declare object in the string. It will not be converted to string automatically. You have to do so in the code, for example:
"[ReceivedTime] < '" + Format(Date, "yyyy/mm/dd") +"' AND [MessageClass] = 'IPM.Note'"
The Restrict method has the following sample on the page in MSDN:
sFilter = "[LastModificationTime] > '" & Format("1/15/99 3:30pm", "ddddd h:nn AMPM") & "'"
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 modified my search email code to count.
Public Sub mycounter()
Dim outlookapp
Dim olns As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Object
'Dim olMail As Outlook.MailItem
Dim myTasks
Dim projIDsearch As String
Dim myrecipient As Outlook.Recipient
Dim daysAgo As Long
Dim strfilter As String
Dim emailcount As Integer
Set outlookapp = CreateObject("Outlook.Application")
Set olns = outlookapp.GetNamespace("MAPI")
Set myrecipient = olns.CreateRecipient("SharedMailbox")
myrecipient.Resolve
Set Fldr = olns.GetSharedDefaultFolder(myrecipient, olFolderInbox)
daysAgo = CInt(ProjIDSearcher.ComboBox1.Text)
Set myTasks = Fldr.Items
Set myTasks = myTasks.Restrict("[ReceivedTime]>'" & Format(Date - daysAgo, "DDDDD HH:NN") & "'")
For Each olMail In myTasks
emailcount = emailcount + 1
'Exit For
Next
MsgBox "here it is:" & emailcount
End Sub
This code counts by days back. Is there a way I can throw a specific date from a dropdown to this?
Set myTasks = myTasks.Restrict("[ReceivedTime]>'" & Format(Date - daysAgo, "DDDDD HH:NN") & "'")
Right now, daysAgo is taking number values from a drop down. I need to count emails for a specific month/year so I can count the number of emails received in let's say January 2017 or May 2016.
I cannot test your code, but the construction of the filter to allow for retrieval of items in a given date range can look like:
sFilter = ""
sFilter = "[ReceivedTime] >= '" & Format(StartDate, "ddddd h:nn AMPM") & "'"
sFilter = sFilter & " AND [ReceivedTime] <= '" & Format(EndDate, "ddddd h:nn AMPM") & "'"
The rules for construction of the filter can be found in the MSDN knowledge base under the Items.Restrict(filter) discussion.
In the above, note that EndDate would logically need to be the day after the desired ending date, assuming you want the count to include EndDate (or you could do EndDate +1 and a < operator).
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.