I found the below script online and tried to modify. I would like to check the Color Category instead of flagged emails.
So as an example, it would not check if an email is flagged and then export the details to excel, but it would export all and add a Column 6 about the Category (name) the email is marked.
Here is the code for processing the emails in Outlook
Sub ProcessMailFolders(ByVal objCurrentFolder As Outlook.Folder)
Dim i As Long
Dim objMail As Outlook.MailItem
Dim objFlaggedMail As Outlook.MailItem
Dim nLastRow As Integer
Dim objSubfolder As Outlook.Folder
For i = 1 To objCurrentFolder.Items.Count
If objCurrentFolder.Items(i).Class = olMail Then
'Export the information of each flagged email to Excel
Set objMail = objCurrentFolder.Items(i)
If objMail.IsMarkedAsTask = True And objMail.FlagStatus <> olFlagComplete Then
Set objFlaggedMail = objMail
With objExcelWorksheet
nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nLastRow) = objFlaggedMail.Subject
.Range("B" & nLastRow) = objFlaggedMail.TaskStartDate
.Range("C" & nLastRow) = objFlaggedMail.TaskDueDate
.Range("D" & nLastRow) = objFlaggedMail.SenderName
.Range("E" & nLastRow) = objFlaggedMail.To
End With
End If
End If
Next i
If objCurrentFolder.Folders.Count > 0 Then
For Each objSubfolder In objCurrentFolder.Folders
Call ProcessMailFolders(objSubfolder)
Next
End If
End Sub
The code referring to Excel I was able to modify, but not with checking the categorisation instead of flagged emails.
You need to alter the 'if' statement. Mail Items have a property called categories which returns a string.
Change:
If objMail.IsMarkedAsTask = True And objMail.FlagStatus <> olFlagComplete Then
To:
If objMail.Categories = ***Insert Category Name In Quotes*** Then
Related
EDITED
I wrote macro that finds an e-mail in shared mailbox and then replies to it. The problem is that for some cases I would like to remove my address (shared#mailbox) or some other and I don't know how to do it. I tried some methods that I found but none worked. Sorry for such a basic question.
Const olFolderInbox = 6
Sub Reminder()
On Error Resume Next
Dim olMail As Outlook.MailItem
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Set Outl = CreateObject("Outlook.Application")
Set myNamespace = Outl.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("shared#inbox")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("Inbox").Folders("AAA").Folders("BBB")
Set colItems = objFolder.Items
Dim i As Long
Dim Folder As Outlook.Folder
i = 1
For Each olMail In objFolder.Items
If olMail.Subject = "AAA" + ActiveSheet.Range("D" & (ActiveCell.Row)) Then
Set oReplyAll = olMail.ReplyAll
oReplyAll.HTMLBody = "<BODY style=font-size:10pt; font-family:Arial>Dear ,<br /> <br />" _
& "Could you please remind the client to do something?<br />" _
& "Thank you in advance.<br />" _
<br /> </BODY>" _
& oReplyAll.HTMLBody
oReplyAll.CC = "xyz#xyz"
'////////////////////////////////////////////////////////////////
'EDIT
'////////////////////////////////////////////////////////////////
For j = 1 To oReplyAll.Recipients.Count
With oReplyAll.Recipients(j)
If .Name = "aaa#bbb" Then
.Delete
j = j - 1
End If
End With
Next j
oReplyAll.Display
i = i + 1
End If
Next olMail
End Sub
Edit: I've added loop iSpain17 wrote3 in a comment. Nothing changed. Reply displays normally with recipient in "To:" part although he should be removed
There is a high probability that the text you want to match is not what you think it is.
Remove On Error Resume Next so you can fix any errors in this untested code.
With this structure you can delete/move more than one match as the index is not corrupted.
For j = oReplyAll.Recipients.Count to 1 step -1
With oReplyAll.Recipients(j)
debug.print "text to match " & .name
If .Name = "text to match" Then
.Delete
End If
End With
Next j
With this structure you can delete/move one match reliably.
For j = 1 To oReplyAll.Recipients.Count
With oReplyAll.Recipients(j)
debug.print "text to match " & .name
If .Name = "text to match" Then
.Delete
' exit now,
' else next item is skipped,
' as it moves up into the position of the deleted item
exit for
End If
End With
Next j
EDITED: Please note, that when you use the Recipients.Add method, you set the Name property of your item. Thus, when you use for loop, you'll have to test against the Name property. Also, deleting an item modifies all other item's index, thus the i=i-1. I tried this, it worked for me.
For i = 1 To email.Recipients.Count
With email.Recipients(i)
If .Name = "address" Then
.Delete
i = i - 1
End If
End With
Next i
This loops through each recipient in the recipients, and if they match the given emailmaddress they are removed from the recipients.
This might not be the exact answer as i am not too familiar with outlook vba, but this is the logic i would use.
I need to generate a series of emails that attach pdf files from specific folders. I am a novice but have some understanding of the code that I'm using. My problem is that I cannot control the number of emails being generated. I want to be able to generate the exact number of emails that there are entries in my directory (rows).
This is the code, any help would be greatly appreciated:
Sub create_email()
'On Error Resume Next
'Dim oMail As Outlook.MailItem`
'Dim num_clients, start_row As Integer`
Sheets("Control").Activate
start_row = Range("start_row").row
num_clients = Range("B100").End(xlUp).row - start_row
For i = 1 To num_clients
Set oMail = Outlook.Application.CreateItem(olMailItem)
'Subject line
oMail.Subject = Range("J9").Offset(i - 1, 0)
'Distribution list
Set RecipTo = oMail.Recipients.Add(Range("K9").Offset(i - 1, 0))
RecipTo.Type = olTo
Set RecipCC = oMail.Recipients.Add(Range("L9").Offset(i - 1, 0))
RecipCC.Type = olCC
oMail.SentOnBehalfOfName = "email#email.com.au"
oMail.Recipients.ResolveAll
'Attachments + message
oMail.Attachments.Add Range("E9").Offset(i - 1, 0) & "\" & Range("F9").Offset(i - 1, 0)
oMail.HTMLBody = "<html><p><font face=""Calibri""><font size=3>Dear Sir/ Madam,</p>" & _
"<html><p><font face=""Calibri"">Kind regards,</p>"
'Displays email pre-send
oMail.Display
Sheets("Control").Activate
Set oMail = Nothing
Next i
End Sub
Is this what you are trying? (Untested)
Sub create_email()
Dim OutApp As Object, oMail As Object
Dim wb As Workbook, ws As Worksheet
Dim i As Long, start_Rows As Long, Last_Row As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Control")
With ws
start_Row = .Range("start_row").Row '<~~ Start Row
Last_Row = .Range("B" & .Rows.Count).End(xlUp).Row '<~~ End Row
Set OutApp = CreateObject("Outlook.Application")
For i = start_Row To Last_Row '<~~ Loop from start row to end row
Set oMail = OutApp.CreateItem(0)
With oMail
.Subject = ws.Range("I" & i).Value
.To = ws.Range("J" & i).Value
.Cc = ws.Range("K" & i).Value
.SentOnBehalfOfName = "email#email.com.au"
.Attachments.Add ws.Range("D" & i).Value & "\" & ws.Range("E" & i).Value
.HTMLBody = "<html><p><font face=""Calibri""><font size=3>Dear Sir/ Madam,</p>" & _
"<html><p><font face=""Calibri"">Kind regards,</p>"
.Display
End With
Next i
End With
End Sub
Basically I have a list of 5000 strings populated in an Excel spreadsheet. I want VBA to go through the attachments in an Outlook Inbox and if it finds a string match, I want the particular email to be flagged. Here's the code I have so far
Sub attachsearch()
On Error GoTo bigerror
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim subfolder As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim filename As String
Dim i As Integer
Dim varresponse As VbMsgBoxResult
Dim workbk As Workbook
Dim SearchString As String
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set subfolder = inbox.Folders("test")
Set workbk = Workbooks.Open("C:\Users\John.Doe\Desktop\10 25 2016 Pricing Team Macro.xlsm")
i = 0
If subfolder.Items.Count = 0 Then
MsgBox "There are no emails to look at. Please stop wasting my time.", vbInformation, "Folder is Empty"
Exit Sub
End If
For Each item In subfolder.Items
For Each atmt In item.Attachments
For rwindex = 1 To 5000
SearchString = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
Below is the problem code, index proberty is not used correctly here, but I'm unsure what to use. I know that Microsoft indexes the words within the attachment because when I manually type in the search string in Outlook, it pulls up the email even though the string is only present within the attachment. So ultimately, my question is, how do I leverage that attachment index in VBA?
If atmt.Index Like "*" & Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value & "*" Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
Next rwindex
Next atmt
Next item
If i > 0 Then
MsgBox "I found " & i & " attached files with a specific name."
Else
MsgBox "I didn't find any files"
End If
Set atmt = Nothing
Set item = Nothing
Set ns = Nothing
workbk.Close savechanges:=False
Exit Sub
bigerror:
MsgBox "something went wrong"
End Sub
Any help would be greatly appreciated, thanks in advance!
Here's a solution if you only need to search the contents PDFs, MSWord, and Excel. There's a different procedure for each. A caveat is that you need to have a version of Adobe that you pay for. This won't work on plain Adobe Reader. I've tested it a few times and it works, but it seems kind of chunky in some parts so I'm open to suggestions.
Sub attachsearch()
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim subfolder As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim tempfilepath As String
Dim tempfilename As String
Dim i As Integer
Dim workbk As Workbook
Dim LastRow As Long
Dim TextToFind As String
Dim Loc As Range
Dim Sh As Worksheet
Dim WS_Count As Integer
Dim x As Integer
Dim WS_Name As String
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set subfolder = inbox.Folders("test")
Set workbk = Workbooks.Open("C:\Users\John.Doe\Desktop\10 25 2016 Pricing Team Macro.xlsx")
LastRow = Workbooks("10 25 2016 Pricing Team Macro").Worksheets("NDC Sort").Cells(Worksheets("NDC Sort").Rows.Count, "A").End(xlUp).Row
i = 0
If subfolder.Items.Count = 0 Then
MsgBox "There are no emails to look at. Please stop wasting my time.", vbInformation, "Folder is Empty"
Exit Sub
End If
For Each item In subfolder.Items
For Each atmt In item.Attachments
If item.FlagStatus = Empty Then
If Right(atmt.Filename, 4) Like "xl**" Or Right(atmt.Filename, 3) Like "xl*" Then
tempfilepath = "O:\aaaTEST\"
tempfilename = Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
atmt.SaveAsFile tempfilepath & tempfilename
Workbooks.Open (tempfilepath & tempfilename)
Workbooks(tempfilename).Activate
WS_Count = Workbooks(tempfilename).Worksheets.Count
'Clearing any selections that may limit the search unintentionally
For x = 1 To WS_Count
With ActiveWorkbook.Worksheets(x)
.Select
.Cells(1, 1).Select
Application.CutCopyMode = False
End With
Next x
For rwindex = 2 To LastRow
If item.FlagStatus = Empty Then
TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
If TextToFind <> "" Then
Workbooks(tempfilename).Activate
For x = 1 To WS_Count
With ActiveWorkbook.Worksheets(x)
.Select
.UsedRange.Select
Set Loc = .Cells.Find(TextToFind)
If item.FlagStatus = Empty Then
If Not Loc Is Nothing Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
End If
Set Loc = Nothing
End With
Next x
End If
End If
Next rwindex
Workbooks(tempfilename).Close Savechanges:=False
End If
'PDF Check
If Right(atmt.Filename, 3) = "pdf" Then
tempfilename = "O:\aaaTEST\" & _
Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
atmt.SaveAsFile tempfilename
PDFPath = tempfilename
Set App = CreateObject("AcroExch.App", "")
Set AVDoc = CreateObject("AcroExch.AVDoc")
If AVDoc.Open(PDFPath, "") = True Then
AVDoc.BringToFront
For rwindex = 2 To 3593
If item.FlagStatus = Empty Then
TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
If AVDoc.FindText(TextToFind, False, True, False) = True Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
AVDoc.Close True
App.Exit
End If
Next rwindex
End If
End If
'MSWord check
If Right(atmt.Filename, 4) Like "doc*" Or Right(atmt.Filename, 3) Like "doc" Then
tempfilepath = "O:\aaaTEST\"
tempfilename = Format(item.ReceivedTime, "yyyymmdd_hhnnss_") & item.SenderName & "_" & atmt.Filename
atmt.SaveAsFile tempfilepath & tempfilename
Set wordapp = CreateObject("word.Application")
wordapp.Documents.Open Filename:=tempfilepath & tempfilename
wordapp.Visible = True
For rwindex = 2 To 5
If item.FlagStatus = Empty Then
TextToFind = Workbooks("10 25 2016 Pricing Team Macro").Sheets("NDC Sort").Cells(rwindex, 1).Value
If TextToFind <> "" Then
With wordapp.ActiveDocument.Content.Find
.ClearFormatting
.Execute FindText:=TextToFind
If .Found = True Then
i = i + 1
With item
.FlagRequest = "Follow up"
.Save
End With
End If
End With
End If
End If
Next rwindex
wordapp.ActiveDocument.Close Savechanges:=wdDoNotSaveChanges
wordapp.Quit Savechanges:=wdDoNotSaveChanges
End If
End If
Next atmt
Next item
Workbooks("10 25 2016 Pricing Team Macro").Close Savechanges:=False
If i > 0 Then
MsgBox "I found " & i & " attached files with a specific name."
Else
MsgBox "I didn't find any files"
End If
Set atmt = Nothing
Set item = Nothing
Set ns = Nothing
Exit Sub
End Sub
What would be the VBA code for looping through a specific folder in outlook 2010 that is NOT the default inbox nor a subfolder of the inbox?
Dim ns As Outlook.NameSpace
Dim folder As MAPIFolder
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = Please help me :-)
Thank you for any hint and help, greetings Ionic
Change
Set ns = Session.Application.GetNamespace("MAPI")
To
Set ns = Session.Application.GetNamespace("MAPI").PickFolder
This will prompt you to select the folder.
Here's a full routine that I wrote some time ago that may be of assistance, bear in mind this was written so that it could be run from Excel but should provide you with the syntax that you need:
Sub GetMail()
'// This sub is designed to be used with a blank worksheet. It will create the header
'// fields as required, and continue to populate the email data below the relevant header.
'// Declare required variables
'-------------------------------------------------------------
Dim olApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim strBody As String
Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
'-------------------------------------------------------------
'//Turn off screen updating
Application.ScreenUpdating = False
'//Setup headers for information
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
'//Format columns E and F to
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
'//Create instance of Outlook
Set olApp = CreateObject("Outlook.Application")
'//Select folder to extract mail from
Set olFolder = olApp.GetNamespace("MAPI").PickFolder
'//Get count of mail items
totalItems = olFolder.items.Count
mailCount = 0
'//Loop through mail items in folder
For Each loopControl In olFolder.items
'//If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
'//Increase mailCount
mailCount = mailCount + 1
'//Inform user of item count in status bar
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
'//Get mail item
Set olMailItem = loopControl
'//Get Details
With olMailItem
strTo = .To
'//If strTo begins with "=" then place an apostrophe in front to denote text format
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
'//If sender displays name only, show name followed by email address e.g.(Bloggs, Joe < j.bloggs#mail.com >)
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .SentOn
dateReceived = .ReceivedTime
strSubject = .Subject
strBody = .Body
End With
'//Place information into spreadsheet
'//import information starting from last blank row in column A
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = strTo
.Offset(0, 1).Value = strFrom
.Offset(0, 2).Value = strSubject
'//Check for previous replies by looking for "From:" in the body text
'//Check for the word "From:"
If InStr(0, strBody, "From:") > 0 Then
'//If exists, copy start of email body, up to the position of "From:"
.Offset(0, 3).Value = Mid(strBody, 1, InStr(1, strBody, "From:") - 1)
Else
'//If doesn't exist, copy entire mail body
.Offset(0, 3).Value = strBody
End If
.Offset(0, 4).Value = dateSent
.Offset(0, 5).Value = dateReceived
End With
'//Release item from memory
Set olMailItem = Nothing
End If
'//Next Item
Next loopControl
'//Release items from memory
Set olFolder = Nothing
Set olApp = Nothing
'//Resume screen updating
Application.ScreenUpdating = True
'//reset status bar
Application.StatusBar = False
'//Inform user that code has finished
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub
Okay, I've found it myself.
Set folder = ns.GetDefaultFolder(olFolderInbox).Parent.Folders(NAME OF THE FOLDER)
Than you for your help guys !
I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?
Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?
Code:
Sub SplitFile()
Dim rTemp As Range
Dim regions() As String
Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
Set wb = Workbooks.Add
ThisWorkbook.Sheets("DVal").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
With ThisWorkbook.Sheets("Combined")
.AutoFilterMode = False
' .AutoFilter
.Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
Application.DisplayAlerts = False
.Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
Application.DisplayAlerts = True
For c = 1 To 68
wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
With wb
.Sheets("Sheet1").Activate
.SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
.Close True
End With
Set wb = Nothing
Next N
End Sub
I am assuming you want to do it programmaticaly using VB, you can do something like
Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage()
msg.From = "noone#nobody.com"
msg.To = "someone#somewhere.com"
msg.Subject = "Email with Attachment Demo"
msg.Body = "This is the main body of the email"
Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls")
msg.Attachments.Add(attch)
SmtpMail.Send(msg)
If you're having trouble with the above, my mail macro is different; this is used with excel 2007:
Sub Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
"This is a test!" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.to = "anyone#anywhere.com"
.cc = ""
.BCC = ""
.Subject = "This is only a test"
.Body = strbody
'You can add an attachment like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Jon
I am assuming the following.
1) Regions are in Col AH
2) Contacts are in Col AI
3) UniqueItems() in your code removes duplicates?
Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.
NOTE: I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.
Option Explicit
Sub SplitFile()
'~~> Excel variables
Dim wb As Workbook, wbtemp As Workbook
Dim rTemp As Range, rng As Range
Dim regions() As String, FileExt As String, flName As String
Dim N As Long, FileFrmt As Long
'~~> OutLook Variables
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strTo As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'~~> Just Regions
Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
'~~> Regions and Email address. We wil require this later
'~~> Tofind email addresses
Set rng = wb.Sheets("Combined").Range("AH2:AI1455")
regions = UniqueItems(rTemp, False)
'~~> Create an instance of outlook
Set OutApp = CreateObject("Outlook.Application")
For N = 1 To UBound(regions)
Set wb1 = Workbooks.Add
wb.Sheets("DVal").Copy after:=wb1.Sheets(1)
With wb.Sheets("Combined")
.AutoFilterMode = False
With .Range("A1:BP1455")
.AutoFilter Field:=34, Criteria1:=regions(N)
'~~> I think you want to copy the filtered data???
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
wb1.Sheets("Sheet1").Range("A1")
For c = 1 To 68
wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
wb.Columns(c).ColumnWidth
Next c
End With
End With
'~~> Set the relevant Fileformat for Save As
' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
FileFrmt = 52
Select Case FileFrmt
Case 50: FileExt = ".xlsb"
Case 51: FileExt = ".xlsx"
Case 52: FileExt = ".xlsm"
Case 56: FileExt = ".xls"
End Select
'~~> Contruct the file name.
flName = "H:\" & regions(N) & " 14-12-11" & FileExt
'~~> Do the save as
wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
wb1.Close SaveChanges:=False
'~~> Find the email address
strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)
'~~> Create new email item
Set OutMail = OutApp.CreateItem(0)
'~~> Create the body of the email here. Change as applicable
strbody = "Dear Mr xyz..."
With OutMail
.To = strTo
.Subject = regions(N) & " 14-12-11" '<~~ Change subject here
.Body = strbody
.Attachments.Add flName
'~~> Uncomment the below if you just want to display the email
'~~> and comment .Send
'.Display
.Send
End With
Next N
LetContinue:
Application.ScreenUpdating = True
'~~> CleanUp
On Error Resume Next
Set wb = Nothing
Set wb1 = Nothing
Set OutMail = Nothing
OutApp.Quit
Set OutApp = Nothing
On Error GoTo 0
Whoa:
MsgBox Err.Description
Resume LetContinue
End Sub