I've a VBA macro that will save an email with the file name "yymmdd.hhmm.[Sender].[Recipient].[Subject Line].txt" that works almost the way I want.
The issue is that the time displayed in Outlook (and the files that are saved) will round the received time to the nearest minute. Outlook will take the received time from the header, but if an email is received at 30-59 seconds past the minute, it will “round up” to the next minute. So an email received at 15:00:30 will display in Outlook (and my saved txt file) as 3:01pm.
The generated file name, however, will display the "hhmm" as "1500"
This discrepancy is causing issues because it looks like times are being altered.
How do I either get my macro to round to the nearest minute, or get Outlook to not round up the displayed time?
Option Explicit
Public Sub SaveMessageAsTxt()
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.SenderName & "." & oMail.Recipients(1) & "." & oMail.Subject
ReplaceCharsForFileName sName, ""
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yymmdd.", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & "." & sName & ".txt"
sPath = enviro & "\Documents\Saved Emails\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olTXT
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
Manually round the date?
Dim intSeconds As Integer
intSeconds = Second(dtDate)
If intSeconds > 29 Then
dtDate = DateAdd("s", 60 - intSeconds, dtDate)
End If
Related
When the code constructs my email subject line, adding the date and time, it also adds a big space before the .msg file extension.
If I don't delete the space when the message box comes up for me to check the saving location, the code jumps to the error handler.
If I delete the space (which looks like 4 or 5 spaces), the file saves correctly.
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim atch As Attachment
Dim sPath, strFolderPath As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim answer As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim jobNumber As String
On Error GoTo errHandler
enviro = CStr(Environ("USERPROFILE"))
jobNumber = InputBox("Please enter job number", "Saving to Job Folder", "Enter Job Number Here")
If jobNumber = "" Then Exit Sub
'create default name for saving file
If IsNumeric(jobNumber) Then
strFile = Int(jobNumber / 100) & "00-" & Int(jobNumber / 100) & "99\" & jobNumber & "\"
Else
strFile = ""
End If
strPathFile = "\\vacdc\VCI JOBS\" & strFile
If Dir(strPathFile, vbDirectory) = vbNullString Then
strFile = Int(jobNumber / 100) & "00-" & Int(jobNumber / 100) & "99\"
strPathFile = "\\vacdc\VCI JOBS\" & strFile
End If
answer = MsgBox(strPathFile, vbYesNoCancel + vbQuestion, "Save emails here?")
If answer = vbYes Then
sPath = strPathFile
Else
If answer = vbCancel Then GoTo exitHandler
strFolderPath = BrowseForFolder("\\vacdc\VCI JOBS\")
sPath = strFolderPath & "\"
End If
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, " mm-dd-yyyy", vbUseSystemDayOfWeek, _
vbUseSystem) & " " & sName & ".msg"
sName = InputBox("", "", sName)
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
I was asked to add this subroutine that my code from earlier post calls:
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
The code where the Subject property is used:
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, " mm-dd-yyyy", vbUseSystemDayOfWeek, _
vbUseSystem) & " " & sName & ".msg"
sName = InputBox("", "", sName)
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
I'd suggest grabbing the subject string and try to save any file with such name. Are you able to get the file saved?
If the pure subject line works correctly as a file name, than I'd suggest checking the parameter string passed to the SaveAs method. Most probably it contains forbidden symbols. The forbidden printable ASCII characters on Windows are:
< (less than)
> (greater than)
: (colon - sometimes works, but is actually NTFS Alternate Data Streams)
" (double quote)
/ (forward slash)
\ (backslash)
| (vertical bar or pipe)
? (question mark)
* (asterisk)
See What characters are forbidden in Windows and Linux directory names? for more information.
Finally, I'd suggest using string functions to replace forbidden symbols with allowed ones. For example, you may find the VBA Replace function helpful.
I have the below code to "automatically" download Outlook emails to a specific local directory.
I would like to be more specific in regards to the file name for the saved mail.
I need to search the email subject and or body to find a string of text in the format AANNNNNNA, where A is a letter and N is a number. If found use that in place of the subject body in the resultant file name, if none is present use the subject of the email.
I can't figure out how to search for the format above.
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
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\XXXXXX\Desktop\Test\"
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
Here's one way of doing it by simply parsing the string:
Public Function FindCode(sCode As String) As String
Dim sCheck As String
Dim nIndex As Integer
For nIndex = 1 To Len(sCode) - 8
sCheck = Mid$(sCode, nIndex, 9)
If IsNumeric(Mid$(sCheck, 3, 6)) And _
Not IsNumeric(Mid$(sCheck, 1, 2)) And _
Not IsNumeric(Mid$(sCheck, 9, 1)) Then
FindCode = sCheck
Exit Function
End If
Next
FindCode = "[not found]"
End Function
Regex might be an option for you (https://learn.microsoft.com/en-us/dotnet/standard/base-types/regular-expression-language-quick-reference) but given the simplicity of the search pattern then the Like operator seems an obvious choice (https://msdn.microsoft.com/VBA/Language-Reference-VBA/articles/like-operator).
The only drawback with Like is that it doesn't return the location of the match in your search string (it just returns True or False), so you'd need to iterate your search string in batches of 9 characters to find the match and then return it.
Public Sub RunMe()
Dim str As String
Dim nme As String
str = "To whom it may concern, find this: AB123456C. Happy coding, Ambie"
nme = FindName(str)
If nme <> "" Then MsgBox nme
End Sub
Private Function FindName(searchText As String) As String
Const PTRN As String = "[A-Za-z][A-Za-z]######[A-Za-z]"
Dim txt As String
Dim i As Long
If Len(searchText) >= 9 Then
For i = 1 To Len(searchText) - 9 + 1
txt = Mid(searchText, i, 9)
If txt Like PTRN Then
FindName = txt
Exit Function
End If
Next
End If
End Function
I am trying to get an Outlook macro to work that simply saves emails as .msg files, with specific formatting, for archiving reasons.
Analogous to another user on here, I am using the following piece of code, resulting in the file format "yymmdd_sender_title.msg", which is exactly what I want, except that I need to get the sender's last name only, instead of the whole name.
Any help is greatly appreciated!
Thank you.
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
Dim sSenderName 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, ""
sSenderName = oMail.SenderName
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & "_" & sSenderName & "_" & sName & ".msg"
sPath = enviro & "\Documents\"
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
You can only retrieve address entry details if it comes from the same Exchange server you are on (AddressEntry.GetExchnageUserUser()). Otherwise the display name is all that you get.
Try using Split Function
Example
sSenderName = oMail.SenderName
sSenderName = Split(sSenderName, " ")(1)
Then the rest of your code
How to split Full Name field into First Name, Last Name and Middle Initial
Extracting First And Last Names
I need to copy a whole lot of e-mails to a folder, but instead of saving them using the subject line I want the file name of the saved e-mail to be that of the attachment in the e-mail.
All I currently have is the code to save the e-mail using the subject line:
Sub Sample()
Dim selectedEmail As MailItem
Dim emailsub As String
Set selectedEmail = ActiveExplorer.Selection.Item(1)
attach = GetValidName(selectedEmail.subject)
'Debug.Print emailsub
With selectedEmail
.SaveAs "C:\direcotry\folder\" & attach & ".msg", OlSaveAsType.olMSG
End With
End Sub
Function GetValidName(sSub As String) As String
'~~> File Name cannot have these \ / : * ? " < > |
Dim sTemp As String
sTemp = sSub
sTemp = Replace(sTemp, "\", "")
sTemp = Replace(sTemp, "/", "")
sTemp = Replace(sTemp, ":", "")
sTemp = Replace(sTemp, "*", "")
sTemp = Replace(sTemp, """", "")
sTemp = Replace(sTemp, "<", "")
sTemp = Replace(sTemp, ">", "")
sTemp = Replace(sTemp, "|", "")
GetValidName = sTemp
End Function
How can I determine the name of an attachment in the e-mail?
Work with DisplayName Property
Option Explicit
Public Sub SaveAsAttchmentName()
'// Declare variables-
Dim olMail As Outlook.MailItem
Dim olItem As Object
Dim sPath As String
Dim sName As String
Dim olAtt As Outlook.Attachment
For Each olItem In ActiveExplorer.Selection
If olItem.MessageClass = "IPM.Note" Then
Set olMail = olItem
For Each olAtt In olMail.Attachments
'// SaveAs Attachment Name-
sName = olAtt.DisplayName
'// Call Function-
ReplaceCharsForFileName sName, "-"
sName = sName & ".msg"
'// SaveAs Path-
sPath = "C:\temp\"
olMail.SaveAs sPath & sName, olMsg
Next
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
Best place to start is - Getting Started with VBA in Outlook 2010
Code Tested on Outlook 2010
I am trying to transfer emails en masse from Outlook 2007 to my C:/ drive. The the idea is to save emails based on their subject and the date as an easy to read identifier.
There is a runtime error when there are two emails with the same subject and date stamp, a naming collision if you will.
Can I add a unique sequential number or a fraction of a second to the file name?
In .NET, I would just add ss^ff or something, but I do not know how to do this with visual basic for applications.
*
Public Sub SaveAllMailsAsFile1()
Dim obj As Object
Dim oItems As Outlook.Items
Dim i As Long
Set oItems = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Acton").Items
For i = oItems.Count To 1 Step -1
Set obj = oItems(i)
If TypeOf obj Is Outlook.MailItem Then
SaveMailAsFile obj, "C:\Users\gasparm\Desktop\MB Emails\Acton\"
End If
Next
End Sub
Private Sub SaveMailAsFile(oMail As Outlook.MailItem, _
sPath As String _
)
Dim dtDate As Date
Dim sName As String
Dim sFile As String
Dim sExt As String
sExt = ".msg"
' Remove invalid file name characters
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
' Build file name from subject and received date
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy-mmm-dd HH.mm.ss ", vbMonday, vbFirstJan1) _
& " - " & sName & sExt
oMail.SaveAs sPath & sName, olMSG
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
*
Probably not the prettiest, but try something like this.
Dim ver as long
Dim sValidSubjectName As String
' Remove invalid file name characters
sValidSubjectName = oMail.Subject
ReplaceCharsForFileName sValidSubjectName, "_"
ver = 0
' Build file name from subject and received date
dtDate = oMail.ReceivedTime
uniqueName:
sName = Format(dtDate, "yyyy-mmm-dd HH.mm.ss ", vbMonday, vbFirstJan1) _
& " - " & sValidSubjectName & ver & sExt
If Dir(sPath & sName) = "" Then
oMail.SaveAs sPath & sName, olMSG
Else
ver = ver + 1
Goto uniqueName
End If