I need to extract outlook emails and name it with part of the sender email address (after "#" and before ".com"). My codes works fine but as for the renaming part, some of the files are not assigned correctly, especially emails within a thread. I had tried searching for solutions for the past 2 weeks, but failed to do so. Would appreciate if anyone could help me out on this issue. Thanks!
[UPDATED]:
Within a thread: It's the running list of all the succeeding replies starting with the original email.
I've wrote codes to extract emails into a designated location and after it is extracted, that email should be named "company's name_datetime received_title of email". Username Suppose to be extracted from sender email address. For example, if I received email from john#companyA.com, subject header is "project" , when I run extraction, the renaming way should be "company A_12-08-2017 09:30AM_Project".
However, with this current code, some of the emails will be named with different company name especially emails in thread. For example, john#companyA.com send an email with title "Project" and I (cheese#companyB.com) replied back and title now becomes "RE:Project". When I run extraction, the email renaming way for the email "Project" is correct, whereas for email "RE:Project", the renaming outcome turns out to be "companyC_datetime received_RE:Project" where Company C does not even exist in that email. (Company C comes from other emails).
Set SubFolder = OutlookApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set MItem = SubFolder.Items(j)
strEmail = Split(SubFolder.Items(j).SenderEmailAddress, "#")(1)
If (InStr(1, strEmail, ".") > 0) Then
strFullName = Split(strEmail, ".")(0)
End If
StrReceived = Format(MItem.ReceivedTime, "dd-mm-yyyy H.MMAMPM")
strSubject = MItem.Subject
'Rename file as Bank name_Date_Title
StrName = StripIllegalChar(strSubject)
StrFile = StrSaveFolder & strFullName & "_" & StrReceived & "_" & StrName & ".msg"
StrFile = Left(StrFile, 256)
MItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
On Error Resume Next is for expected errors.
I suggest there is an unexpected error, likely when the MItem object is not a mailitem.
If so this line would fail.
strEmail = Split(SubFolder.Items(j).SenderEmailAddress, "#")(1)
Now due to the misuse of On Error Resume Next, you do not have a chance to fix errors. strEmail remains what it was before the error.
Dim MItem as object
If MItem.class = olMail then
Related
I would like to have a macro that I can hit, it reads the email subject line 03100-001-01 and it then saves in that directory on my computer. I just have no idea where to start.
I have no tried anything at this stage
You can use the Subject property of Outlook items to get the subject string. Then you can use the InStr function which returns a long (number) specifying the position of the first occurrence of one string within another. For example:
Dim SearchString, SearchChar, MyPos
SearchString ="XXpXXpXXPXXP" ' String to search in.
SearchChar = "P" ' Search for "P".
' A textual comparison starting at position 4. Returns 6.
MyPos = Instr(4, SearchString, SearchChar, 1)
' A binary comparison starting at position 1. Returns 9.
MyPos = Instr(1, SearchString, SearchChar, 0)
' Comparison is binary by default (last argument is omitted).
MyPos = Instr(SearchString, SearchChar) ' Returns 9.
MyPos = Instr(1, SearchString, "W") ' Returns 0.
Finally, to save the item you need to use the MailItem.SaveAs method which saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used.
Sub SaveAsMsg()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
But I'd recommend starting from the following articles to build a basic understanding how VBA macros work:
Getting started with VBA in Office
Using Visual Basic for Applications in Outlook
This is my first time using VBA with Outlook.
I got my code to work but encountered a strange problem as I added a step
The tasks are:
Save emails from subfolder1 to a network folder (this worked fine)
After saving, Move emails from subfolder1 to subfolder2 (adding this step caused issue)
(both subfolder1 and subfolder2 are subfolders in Outlook under the default Inbox folder)
Adding a single line of code for 2nd task caused a strange problem:
For the same 12 emails I was testing, the code would run without error messages but would only process few emails at a time. I would have to re-run code and it took 4 executions to finish all 12 emails.
Emails are processed in this order:
6 emails (the same one in same order every time)
3 emails (the same one in same order every time)
2 emails (the same one in same order every time)
1 email
There are no conditions in the code to stop it.
When I run the same code without adding the line for task#2, the macro processes all 12 emails in one go.
Commenting out this one line solves the "batchiness":
oMail.Move myFolder2
The remaining emails do get processed in subsequent runs; just not in one go.
Here's my code, borrowed mostly from: Macro to save selected emails of Outlook in Windows folder
Sub OutlookToDrive()
Dim myNameSpace As Outlook.NameSpace 'Object '(or Outlook.NameSpace)
Dim myFolder1 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) folder to move FROM
Dim myFolder2 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) Folder to move TO
Dim oMail As Object 'not specifying as 'mailobject' to include meeting invites
Dim sFileName As String
Dim dtdate As Date
Dim sDestinationFolder As String
Dim sFullPath As String
Dim sFolder1Name As String 'name of folder to move FROM
Dim sFolder2Name As String 'name of folder to move TO
Dim iCount As Integer
sDestinationFolder = "H:\PROD\Supplimentary_Info\"
'subfolders under the default Inbox folder:
sFolder1Name = "MoveFrom"
sFolder2Name = "MoveTo"
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder1 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder1Name)
Set myFolder2 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder2Name)
'initialize count
iCount = 0
For Each oMail In myFolder1.items
sFileName = oMail.Subject 'Use email subject as file name
'"ReplaceCharsForFileName" is a function that I'm not including; no issues
ReplaceCharsForFileName sFileName, "()" 'replace characters
dtdate = oMail.ReceivedTime
sFileName = Format(dtdate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & _
Format(dtdate, "-hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-" & sFileName & ".msg"
sFullPath = sDestinationFolder & "\" & sFileName
If Dir(sFullPath) = "" Then
iCount = iCount + 1
Debug.Print TypeName(oMail) & " " & sFileName
oMail.SaveAs sFullPath, olMSG 'save to specified path
DoEvents
oMail.Move myFolder2 'THIS LINE CAUSING ISSUE; BUT FINE IN BATCHES
DoEvents
End If
Next
MsgBox "Found " & iCount & " new emails in folder """ & myFolder1 & """ to save to path: " & vbNewLine & vbNewLine & sDestinationFolder
End Sub
In trying to diagnose the problem, made a list of emails in batches they appear using debug.print list. (Bold prefix number is the order they sit in the mail folder, bold prefix text is email type)
I changed the number of total emails for testing. New batches remained consistent the number of times I repeated:
Total 15 email; batches 8, 4, 2, 1
Total 6 emails; batches 3, 2, 1
Total 5 emails; batches 3, 1, 1
Total 3 emails; batches 2, 1
Total 2 emails; Both went through. yeah!
(The 15 count group was made by adding 3 new emails to original 12 emails in folder1. The 12 emails changed order in which they were processed within new test group. But re-running the macro always gave the same emails in same new batches every time I tested)
Try this:
For i = myFolder1.Items.count -1 to 0 step -1
Set oMail = myFolder1.Items(i)
'Do your thing
Next i
I suspect your loop skips an item because you remove your item from the folder.
Here's modified response posted by Alex de Jong.
Code works nicely when loop is changed to:
For i = myFolder1.Items.count to 1 step -1
Set oMail = myFolder1.Items(i)
'Do your thing
Next i
In windows 7 and Office 2007 I have been using a code which opens a new email in Outlook, attach a file and send it. The code it's not mine, I found it somewhere in the internet. The problem is that now I use Windows 10 and Office 2016, and using the same code produce different results as:
The original name of the file, let's say for example "Products.xlsx", is changed to "ProjectStatus.xlsx" (any file name is always changed to "ProjectStatus.xlsx")
If I open the file then Excel opens it and shows the original name of the file ("Products.xlsx")
If I send it, sometimes the recipients see the attached file as "ProjectStatus.xlsx" and sometimes see it as "Products.xlsx". But what always happens is that if they open the file, in excel is seen as "Products.xlsx"
I need the file name always be shown with the original name. How can I do this?
This is the code I use it and is executed from both access 2016 and excel 2016.
Sub MandaMailA(destinatarios As String, copia As String, subject As String, strbody As String, attachment1 As String, Optional attachment2 As String = "", Optional CO As String = "")
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Firmas\VBA.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = destinatarios
.CC = copia
.BCC = CO
.subject = subject
.HTMLBody = strbody & "<br>" & Signature
.Display 'or use .Display
.Attachments.Add attachment1, olByValue, 1, "ProjectStatus"
.Attachments.Add attachment2, olByValue, 1, "ProjectStatus"
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I notice that this code includes the word "ProjectStatus" but honestly I have not a deep knowledge of VBA.
Thanks in advance!!
A simple read of the Attachments.Add documentation is all you need, specifically the section on the optional DisplayName parameter:
This parameter applies only if the mail item is in Rich Text format
and Type is set to olByValue : the name is displayed in an Inspector
object for the attachment or when viewing the properties of the
attachment. If the mail item is in Plain Text or HTML format, then the
attachment is displayed using the file name in the Source parameter.
So if you always want to always use the original file name, simply delete the instances of , "ProjectStatus".
So there are several SO questions and Google results that come up under "On Error GoTo executes once" and in just about every case the recommended solution is to add Err.Clear or some forum of Resume to clear the error out. VBA errors can only be handled one at a time, so they need to be cleared.
Having implemented these, as you might have guessed, I am running into this issue where the On Error GoTo is only executing once and I can't figure out why.
Below is my loop. I did leave some code off the top because there is quite a bit of it and it isn't relevant. Mostly user prompts and making arrays. To explain a little what is going on, conos() is an array containing the values of a specific column. Based on a segment of the filename, it searches for the code in the array, to get its index, which corresponds to the row.
If there isn't a Match it triggers the error. That just means there is a file, but no contact to send it to. It should skip to NoContact and create a list of these files.
So with my files, the first has a contact and generates the email, the second does not and skips to NoContact and adds the file to the list. Five more run with contacts and then it gets to another that should go to NoContact, but Unable to get the Match property of the WorksheetFunction class comes up.
It seems the error isn't getting cleared from the first one. Not sure why.
For Each objFile In objFolder.Files
wbName = objFile.Name
' Get the cono along with handling for different extensions
wbName = Replace(wbName, ".xlsx", "")
wbName = Replace(wbName, ".xlsm", "")
wbName = Replace(wbName, ".xls", "")
' Split to get just the cono
fileName() = Split(wbName, "_")
cono = fileName(2)
' Create the cell look up
c = Cells(1, WorksheetFunction.Match("Cono", cols(), 0)).Column
' ******************** ISSUE IS HERE ***************************
On Error GoTo NoContact
r = Cells(WorksheetFunction.Match(cono, conos(), 0), c).Row
Cells(r, c).Select
' Fill the variables
email = Cells(r, c).Offset(0, 1).Value
firstName = Cells(r, c).Offset(0, 3).Value
lastName = Cells(r, c).Offset(0, 4).Value
account = Cells(r, c).Offset(0, -2).Value
username = Cells(r, c).Offset(0, 6).Value
password = Cells(r, c).Offset(0, 7).Value
fPassword = Cells(r, c).Offset(0, 8).Value
' Mark as completed
Cells(r, c).Offset(0, 9).Value = "X"
' Set the object variables
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Body of the email
str = "Hi " & firstName & "," & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
' Parameters of the email
On Error Resume Next
With OutMail
.To = email
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = str
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
End With
On Error GoTo 0
' Based on the user prompts, whether or not the emails will be sent without checking them first
If finalCheck = vbYes Then
OutMail.Send
Else
OutMail.Display
End If
NoContact:
' Determiine which files don't have a corresponding email and add to list
If email = Empty Then
If conoB <> "" Then
conoB = conoB & ", " & cono
Else
conoB = cono
End If
End If
Err.Clear
' Clear variables for next use
Set OutMail = Nothing
Set OutApp = Nothing
cono = Empty
email = Empty
firstName = Empty
lastName = Empty
account = Empty
username = Empty
password = Empty
fPassword = Empty
Next:
Err.Clear just clears the information regarding the last error from the Err object - it does not exit out of error handling mode.
If an error is detected and your On Error GoTo NoContact is invoked, your code jumps down to the NoContact label, and then finally finds it way back to the start of your For Each objFile In objFolder.Files loop while still in error-handling mode.
If another error occurs while still in error-handling mode, VBA throws the error as it can no longer trap it.
You should structure your code along the lines of
For Each objFile In objFolder.Files
'...
On Error GoTo NoContactError
'...
NoContact:
'...
Next
'...
Exit Sub
NoContactError:
'Error handling goes here if you want it
Resume NoContact
End Sub
But, as Tim Williams, commented - it is much better to avoid situations that require On Error error-handling whenever possible.
So we are holding this big event and I have an excel sheet with everyones name, email address as well as their itinerary files (there are 2 of them) Cells(x, 3) and Cells(x, 4). What I am trying to do is go down the column and send everyone a 'personalized' email with all of their information.
In the code, the for loop only goes to 3 because I am just testing it out by sending the emails to myself and don't want to end up getting 1000 emails :P
I keep getting a Run-Time Error 440 (Automation Error) at the lines where I attempt to add the attachments... not sure what's going on or how to remedy it any help is appreciated
Code
Sub CreateHTMLMail()
'Creates a new e-mail item and modifies its properties.
Dim olApp As Object
Dim objMail As Object
Dim body, head, filePath, subject As String
Dim x As Long
Set olApp = CreateObject("Outlook.Application")
'Create e-mail item
Set objMail = olApp.CreateItem(0)
filePath = "\\fileserver\homeshares\Tsee\My Documents\Metropolitan Sales\MNF"
subject = "Important Travel Information for MNF Event this weekend"
x = 1
For x = 1 To 3
head = "<HTML><BODY><P>Hi " & Cells(x, 1).Value & ",</P>"
body = body & "<BR /><P>We are looking forward to having you at our <STRONG>Metropolitan Night Football Event</STRONG> this upcoming Sunday, <STRONG>11/17</STRONG>! Note, that the Giants game time has changed from 8:30 PM to 4:25 PM.</P>"
body = body & "<BR /><P>Please find attached your travel information packet that contains important addresses and confirmation numbers. Please read through it and let me know if you have any questions.</P>"
body = body & "<BR /><P>If you need to reach me this weekend, please call my cell phone <STRONG>(631) 793-9047</STRONG> or email me.</P>"
body = body & "<BR /><P>Thanks,<BR />Liz</P></BODY></HTML>"
With objMail
.subject = subject
.To = Cells(x, 2).Value
.Attachments.Add = filePath & "/" & Cells(x, 3).Value
.Attachments.Add = filePath & "/" & Cells(x, 4).Value
.BodyFormat = olFormatHTML
.HTMLBody = head & body
.Send
End With
Next x
End Sub
Further to the above comments, #bamie9l has already solved one problem of yours
Problem 2
#bamie9l Awesome! That worked, but now at the .BodyFormat = olFormatHTML line I get Run-time error '5': Invalid procedure call or argument – metsales 13 mins ago
You are latebinding with Outlook from Excel and olFormatHTML is an Outlook constant and hence Excel is unable to recognize it. In the Immediate Window of MS-Outlook if you type ?olFormatHTML then you will note that the value of that constant is 2
Hence we have to declare that constant in Excel. Like I mentioned, either you can put Const olFormatHTML = 2 at the top of the code or replace .BodyFormat = olFormatHTML by .BodyFormat = 2
Problem 3
#SiddharthRout So that works, but now I get a crazy automation error... it goes through the loop once.. sends 1 email and then when it gets up to .subject = subject I get Run-time error '-2147221238 (8004010a)': Automation Error which as far as I know is the same as Run-Time Error 440 – metsales
The problem is that you are creating the outlook item outside the loop by
Set objMail = olApp.CreateItem(0)
Outlook already sent that email and now for the next email you will have to re-create it. So move that line inside the loop.
For x = 1 To 3
Set objMail = olApp.CreateItem(0)
head = "<HTML><BODY><P>Hi " & Cells(x, 1).Value & ",</P>"
Body = "Blah Blah"
With objMail
.subject = subject
.To = Cells(x, 2).Value
.Attachments.Add = FilePath & "/" & Cells(x, 3).Value
.Attachments.Add = FilePath & "/" & Cells(x, 4).Value
.BodyFormat = olFormatHTML
.HTMLBody = head & Body
.Send
End With
Next x