Good morning all,
I am hoping someone can help me here with a piece of coding.
I am looking to save the selected email to a specific directory, with the name of the email, and of course as a .msg file.
This is what i have today, and it is not working. It saves a file but the name only has the first 2 characters (looks like it errors after the semi colon file name eg: FW or RE)... the content of the file is blank and the filetype has not been applied.
'code to save selected email
Dim selectedEmail As MailItem
Set selectedEmail = ActiveExplorer.Selection.Item(1)
Dim emailsub As String
emailsub = ActiveExplorer.Selection.Item(1).Subject
With selectedEmail
.SaveAs "C:\direcotry\folder\" & emailsub & ".msg", olMSG
End With
Thank you in anticipation.
Dom
The reason is very simple. You email subject contains and Invalid Character. For example : This usually happens when the email is a RE: or FWD:
Try this
Sub Sample()
Dim selectedEmail As MailItem
Dim emailsub As String
Set selectedEmail = ActiveExplorer.Selection.Item(1)
emailsub = GetValidName(selectedEmail.subject)
'Debug.Print emailsub
With selectedEmail
.SaveAs "C:\direcotry\folder\" & emailsub & ".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
Related
I have the following VBA code macro to save all selected e-mails in .msg format to any folder but it doesn't save emails with meeting invitations. How do I also save mails with meeting invitations? Do I have to include any special objects? Below is the code that I am using to save the e-mails in .msg format:
Option Explicit
Public Sub SaveMessageAsMsg()
Dim xShell As Object
Dim xFolder As Object
Dim strStartingFolder As String
Dim xFolderItem As Object
Dim xMail As MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xFileName As String
Dim xName As String
Dim xDtDate As Date
Set xShell = CreateObject("Shell.Application")
On Error Resume Next
' Bypass error when xFolder is nothing on Cancel
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If Not TypeName(xFolder) = "Nothing" Then
Set xFolderItem = xFolder.Self
xFileName = xFolderItem.Path
' missing path separator
If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
Else
xFileName = ""
Exit Sub
End If
For Each xObjItem In ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xName = Left(CleanFileName(xMail.Subject), 100)
Debug.Print xName
xDtDate = xMail.ReceivedTime
xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & "-" & xName & ".msg"
xPath = xFileName & xName
xMail.SaveAs xPath, olMSG
End If
Next
End Sub
Public Function CleanFileName(strFileName As String) As String
Dim Invalids
Dim e
Dim strTemp As String
Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/", "\")
strTemp = strFileName
For Each e In Invalids
strTemp = Replace(strTemp, e, " ")
'strTemp = Replace(strTemp, e, "")
Next
CleanFileName = strTemp
End Function
In the code posted above only mail items are handled:
If xObjItem.Class = olMail Then
There are various object types in Outlook, see OlObjectClass enumeration for more information.
Basically, you need to handle also meeting items:
Dim xMail As Object
If xObjItem.Class = olMail Or xObjItem.Class = olMeetingRequest Then
I've been trying to find a way to modify the SaveAs code to include Me.EvalID_T1.Text userform information into the title of the message.
I know I am missing something, but not sure what it is. Any help would be great!
Thanks!
Dim strPrompt As String, strname As String
Dim sreplace As String, mychar As Variant, strdate As String
Dim M As String ' variable used to store userform info
M = Me.EvalID_T1.Text ' userform info
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
myPath = "C:\Users\cam\Desktop\Test\ & " - path to save file
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
On Error Resume Next
olmail.SaveAs myPath & M & ".msg", olMsg ' unknown how to modify
I used below code from your site to replace strings in a text file and it works fine. But, I don't want specify a file name, it should ready any file like (*.txt or *.xml).
Sub ReplaceStringInFile()
Dim sBuf As String
Dim sTemp As String
Dim iFileNum As Integer
Dim sFileName As String
' Edit as needed
sFileName = "C:\Temp\test.txt"
iFileNum = FreeFile
Open sFileName For Input As iFileNum
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum
sTemp = Replace(sTemp, "THIS", "THAT")
iFileNum = FreeFile
Open sFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
End Sub
Sub ReplaceStringInFile()
Dim sBuf As String
Dim sTemp As String
Dim sFileName As String
Dim FileExt(2) As String
ruta = Application.ActiveWorkbook.Path
ChDrive ruta
ChDir ruta
FileExt(1) = "txt"
FileExt(2) = "xml"
For i = 1 To 2
sFileName = Dir("*." & FileExt(i))
Do
If sFileName = "" Then Exit Do
sTemp = ""
Open sFileName For Input As #1
Do Until EOF(1)
Line Input #1, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close #1
sTemp = Replace(sTemp, "THIS", "THAT")
Open sFileName For Output As #1
Print #1, sTemp
Close #1
sFileName = Dir()
Loop
Next i
End Sub
You can iterate through items in an array!!
Sub FindAndReplaceText()
Dim FileName As String
Dim FolderPath As String
Dim FSO As Object
Dim I As Integer
Dim SearchForWords As Variant
Dim SubstituteWords As Variant
Dim Text As String
Dim TextFile As Object
'Change these arrays to word you want to find and replace
SearchForWords = Array("string1", "string2", "string3")
SubstituteWords = Array("string100", "string200", "string300")
'Change the folder path to where your text files are.
FolderPath = "C:\your_path_here\"
Set FSO = CreateObject("Scripting.FileSystemObject")
FolderPath = IIf(Right(FolderPath, 1) <> "\", FolderPath & "\", FolderPath)
FileName = Dir(FolderPath & "\*.txt")
Do While FileName <> ""
FileSpec = FolderPath & FileName
'Read all the file's text into a string variable.
Set TextFile = FSO.OpenTextFile(FileSpec, 1, False)
Text = TextFile.ReadAll
TextFile.Close
'Scan the string for words to replace and write the string back to the file.
Set TextFile = FSO.OpenTextFile(FileSpec, 2, False)
For I = 0 To UBound(SearchForWords)
Debug.Print Text
Replace Text, SearchForWords(I), SubstituteWords(I)
Debug.Print Text
Next I
TextFile.Write Text
TextFile.Close
FileName = Dir()
Loop
End Sub
I am trying to save selected emails in Outlook as Text files.
I would like it to work like this:
Saves one email at a time but saves all selected emails instead of just a single email.
They need to each be saved as a new file. I know that the export feature saves them all as one large text file, but need them to each have their own.
Here's what I have so far:
Sub SaveEmail()
Dim Msg As Outlook.MailItem
' assume an email is selected
Set Msg = ActiveExplorer.Selection.item(2)
' save as text
Msg.SaveAs "C:\My Location", OLTXT
End Sub
It looks like you need to iterate over all selected items in the explorer window and save each one using the txt file format. Be aware, the Selection object may contain various Outlook item types. The following code showshow to iterate over all items selected and detect what item is:
Private Sub GetSelectedItem_Click()
' This uses an existing instance if available (default Outlook behavior).
' Dim oApp As New Outlook.Application - for running in external applications
Dim oExp As Outlook.Explorer
Dim oSel As Outlook.Selection ' You need a selection object for getting the selection.
Dim oItem As Object ' You don't know the type yet.
Set oExp = Application.ActiveExplorer ' Get the ActiveExplorer.
Set oSel = oExp.Selection ' Get the selection.
For i = 1 To oSel.Count ' Loop through all the currently .selected items
Set oItem = oSel.Item(i) ' Get a selected item.
DisplayInfo oItem ' Display information about it.
Next i
End Sub
Sub DisplayInfo(oItem As Object)
Dim strMessageClass As String
Dim oAppointItem As Outlook.AppointmentItem
Dim oContactItem As Outlook.ContactItem
Dim oMailItem As Outlook.MailItem
Dim oJournalItem As Outlook.JournalItem
Dim oNoteItem As Outlook.NoteItem
Dim oTaskItem As Outlook.TaskItem
' You need the message class to determine the type.
strMessageClass = oItem.MessageClass
If (strMessageClass = "IPM.Appointment") Then ' Calendar Entry.
Set oAppointItem = oItem
MsgBox oAppointItem.Subject
MsgBox oAppointItem.Start
ElseIf (strMessageClass = "IPM.Contact") Then ' Contact Entry.
Set oContactItem = oItem
MsgBox oContactItem.FullName
MsgBox oContactItem.Email1Address
ElseIf (strMessageClass = "IPM.Note") Then ' Mail Entry.
Set oMailItem = oItem
MsgBox oMailItem.Subject
MsgBox oMailItem.Body
ElseIf (strMessageClass = "IPM.Activity") Then ' Journal Entry.
Set oJournalItem = oItem
MsgBox oJournalItem.Subject
MsgBox oJournalItem.Actions
ElseIf (strMessageClass = "IPM.StickyNote") Then ' Notes Entry.
Set oNoteItem = oItem
MsgBox oNoteItem.Subject
MsgBox oNoteItem.Body
ElseIf (strMessageClass = "IPM.Task") Then ' Tasks Entry.
Set oTaskItem = oItem
MsgBox oTaskItem.DueDate
MsgBox oTaskItem.PercentComplete
End If
End Sub
You can add the SaveAs statement shown in your code where required.
Thank you everybody for your help. I was able to find the answer. Below is what worked for me.
Sub SaveSelectedMailAsTxtFile()
Const OLTXT = 0
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set oMail = obj
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".txt"
oMail.SaveAs "C:\my\path\" & sName, OLTXT
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, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
To save a single selected mail to a text file:
Selected email will be saved to a text file in the path specified in the code
Sub SaveMailAsFile()
Const OLTXT = 0
Dim oMail As Outlook.mailItem
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Set oMail = Application.ActiveExplorer.Selection.Item(1)
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".txt"
oMail.SaveAs "C:\path\to\save\" & sName, OLTXT
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
To save all selected mails to a text file:
NOTE: Click on Tools -> References -> Check the box for Microsoft Scripting Runtime before using this code.
Selected email(s) will be save to the user's standard Documents folder with the date and time stamp
Sub MergeSelectedEmailsIntoTextFile()
Dim objFS As New Scripting.FileSystemObject, objFile As Scripting.TextStream
Dim objItem As Object, strFile As String
Dim Folder As Folder
Dim sName As String
' Use your User folder as the initial path
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
If ActiveExplorer.Selection.Count = 0 Then Exit Sub
' use the folder name in the filename
Set Folder = Application.ActiveExplorer.CurrentFolder
' add the current date to the filename
sName = Format(Now(), "yyyy-mm-dd-hh-MM-ss")
' The folder pathyou use needs to exist
strFile = enviro & "\Documents\" & sName & "-" & Folder & ".txt"
Set objFile = objFS.CreateTextFile(strFile, False)
If objFile Is Nothing Then
MsgBox "Error creating file '" & strFile & "'.", vbOKOnly + vbExclamation _
, "Invalid File"
Exit Sub
End If
For Each objItem In ActiveExplorer.Selection
With objFile
.Write vbCrLf & "--Start--" & vbCrLf
.Write "Sender: " & objItem.Sender & " <" & objItem.SenderEmailAddress & ">" & vbCrLf
.Write "Recipients : " & objItem.To & vbCrLf
.Write "Received: " & objItem.ReceivedTime & vbCrLf
.Write "Subject: " & objItem.Subject & vbCrLf & vbCrLf
.Write objItem.Body
.Write vbCrLf & "--End--" & vbCrLf
End With
Next
objFile.Close
MsgBox "Email text extraction completed!", vbOKOnly + vbInformation, "DONE!"
Set objFS = Nothing
Set objFile = Nothing
Set objItem = Nothing
End Sub
Reference: Save email message as text file
Hers is a shorter Solution I came up with that just saves the body of the message.
Sub selectToText()
Dim Omail As Outlook.MailItem
Set Omail = Application.ActiveExplorer.Selection.Item(1)'Selected Message
Dim subject As String: subject = Omail.subject 'Get subject
Dim rmv As Variant: rmv = Array("\", "/", ":", "*", "?", """", "<", ">", "|") 'Invalid chars for a file name
Dim r As Variant 'holds a char
Dim txtFile As String 'holds dir to save to
For Each r In rmv ' remove invalid chars
subject = Replace(subject, r, "")
Next r
txtFile = "C:\" & subject & ".txt" 'set save to location CHANGE this to where you want to save!
Open txtFile For Output As #1
Write #1, Omail.Body 'write email body to save location
Close #1
End Sub
I’m trying to create a VBA macro that saves an email attachment to folder depending on the email address. For example if I receive and email with an attachment from joey#me.com I want to save that attachment to the directory
\server\home\joey
or if I receive it from steve#me.com the attachment should be saved in
\server\home\steve .
And finally I want send a reply email with the name of the file that has been saved. I found some code that almost does what I want but I having a difficult time modifying it. This is all being done in Outlook 2010. This is what I have so far. Any help would be greatly appreciated
Const mypath = "\\server\Home\joe\"
Sub save_to_v()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String
Dim sreplace As String, mychar As Variant, strdate As String
Set objItem = Outlook.ActiveExplorer.Selection.item(1)
If objItem.Class = olMail Then
If objItem.Subject <> vbNullString Then
strname = objItem.Subject
Else
strname = "No_Subject"
End If
strdate = objItem.ReceivedTime
sreplace = "_"
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "|")
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs mypath & strname & "--" & strdate & ".msg", olMSG
Else
MsgBox "You chose not to save."
End If
End If
End Sub
Is this what you are trying? (UNTESTED)
Option Explicit
Const mypath = "\\server\Home\"
Sub save_to_v()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String, strSubj As String, strdate As String
Dim SaveAsName As String, sreplace As String
Dim mychar As Variant
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
If objItem.Class = olMail Then
If objItem.Subject <> vbNullString Then
strSubj = objItem.Subject
Else
strSubj = "No_Subject"
End If
strdate = objItem.ReceivedTime
sreplace = "_"
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "|")
strSubj = Replace(strSubj, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
strname = objItem.SenderEmailAddress
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
Select Case strname
Case "joey#me.com"
SaveAsName = mypath & "joey\" & strSubj & "--" & strdate & ".msg"
Case "steve#me.com"
SaveAsName = mypath & "steve\" & strSubj & "--" & strdate & ".msg"
End Select
objItem.SaveAs SaveAsName, olMSG
Else
MsgBox "You chose not to save."
End If
End If
End Sub
It will never work. As Outlook 2010 is not saving any msg file to a network drive only local drive is working !!
As described in the documentation of M$ and tested by me.
Simple test with fixed path and filename.
Local c:\ works. Network drive in UNC or L: does not work !!!!