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
Related
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
I have a macro to draft automatic emails based on the recipients in each columns.
However, I'm looking for a code which can if the attachments named in the excel sheet are attached to the email. If there is any attachment missing from that email it should show a msg box with the name of the missing attachment.
SNip of one the sheets attached
Sub Email1()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
Dim FLNM As String
Dim AttchmentName As String
Set AddressList = Sheets("Tracker Summary").Range("Y:Z")
Dim AttchmentName1 As String
Dim path As String
Call FetchFileNames
path = ThisWorkbook.path & "/"
Dim i As Integer
i = 5
With olMail
ActiveSheet.Range("A1").Select
.BodyFormat = olFormatHTML
.Display
.To = ActiveSheet.Cells(2, i).Value
.CC = ActiveSheet.Cells(3, i).Value
.Subject = ActiveSheet.Cells(4, i).Value
.HTMLBody = ActiveSheet.Cells(5, i).Value & .HTMLBody
j = 6
Do Until IsEmpty(Cells(j, i))
On Error Resume Next
FLNM = ActiveSheet.Cells(j, i).Value
AttchmentName1 = Application.WorksheetFunction.VLookup(FLNM, AddressList, 1, True)
If FLNM = AttchmentName1 Then
AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
.Attachments.Add AttchmentName
End If
j = j + 1
Loop
'.Display
End With
Sheets("Tracker Summary").Range("Y:Z").ClearContents
End Sub
Presuming that AttachmentName is a full file path string, maybe your code could check if the file exists beforehand.
For the sake of simplicity...
If Len(Dir(AttachmentName)) = 0 then msgbox "The File " & AttachmentName & " is missing"
... Just after you set AttachmentName value at AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
Obviously, same for any other Attachment variables.
Trying to send email through outlook but it is not saving the excel file and so it's not able to do attachment. Also my code is not able to pop up outlook window. It was working before but due to network drive it no longer works.
Sub Backup_required()
'coded by Atul , Vij
Dim OutlookApp, MItem As Object
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String
Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wb As Workbook, wb2 As Workbook
Dim main_book As String
Dim newWorkbook As String
Application.DisplayAlerts = False
'create outblook object
Set OutlookApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
'defines the user name
user = Environ("username")
main_book = ActiveWorkbook.Name
Set wb = Workbooks(main_book)
'email subject
Subj = "Blackline Reconciliation - Backup Required!"
'coded by Atul , Vij
Call pathDefinition
'operation for all sheets in BS_Download template with comments
For Each g In Workbooks(main_book).Worksheets
Set ws = wb.Worksheets(g.Name)
If g.Name <> "Sap Data" And g.Name <> "Automated BL Import" Then
lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
'select every cells in all sheets in BS_Download template with comments
For Each a In ws.Range("W2:W" & lastRow)
If Left(a, 1) <> "*" And a.Value <> 0 And a.Offset(0, 1).Value = 0 Then
B = a.Row
f = a.Value
'add new book where the cell with met conditions are copied
Workbooks.Add
newWorkbook = ActiveWorkbook.Name
Workbooks(newWorkbook).Worksheets(1).Range("A1:AA1").Value = ws.Range("A1:AA1").Value
Set wb2 = Workbooks(newWorkbook)
Set ws3 = wb2.Worksheets(1)
'select all cells in all sheets in BS_Download template with comments
For Each d In Workbooks(main_book).Worksheets
If d.Name <> "Sap Data" And d.Name <> "Automated BL Import" Then
Set ws2 = wb.Worksheets(d.Name)
'compare if condition is met in all cells in all sheets in BS_Download template with comments
lastRow2 = ws2.Range("B" & Rows.Count).End(xlUp).Row
For Each e In ws2.Range("W2:W" & lastRow2)
C = e.Row
If e.Value = f And Left(e, 1) <> "*" And e.Offset(0, 1) = 0 Then
lastRow3 = ws3.Range("B" & Rows.Count).End(xlUp).Row + 1
ws3.Range("A" & lastRow3, "AA" & lastRow3).Value = ws2.Range("A" & C, "AA" & C).Value
e.Value = "*" & e.Value
If Left(a, 1) <> "*" Then
a.Value = "*" & a.Value
End If
End If
Next e
End If
'coded by Atul , Vij
Next d
ws3.Range("A1:AA1").Interior.Color = RGB(51, 102, 255)
ws3.Columns("A:AA").EntireColumn.AutoFit
'finally save the new opened workbook with name of compared a cell
wb2.SaveAs FileName:="D:\" & f & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wb2.Close
EmailAddr = f
'open new email
Set MItem = OutlookApp.CreateItem(olMailItem)
Set myAttachments = MItem.Attachments
With MItem
.To = EmailAddr
.Subject = Subj
.Display
End With
'paste the attachment of new workbooks save on user desktop
myAttachments.Add "D:\" & f & ".xlsx"
End If
Next a
End If
Next g
'erase the first left "*" in all the cell in T column
For Each a In Workbooks(main_book).Worksheets
Set ws = wb.Worksheets(a.Name)
If a.Name <> "Sap Data" And a.Name <> "Automated BL Import" Then
lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
For Each B In ws.Range("W2:W" & lastRow)
If Left(B, 1) = "*" Then
B.Value = Right(B, (Len(B.Value) - 1))
End If
Next B
End If
Next a
Application.DisplayAlerts = True
End Sub
The problem is on this line (don't know what it could be with out a copy of the workbook):
If Left(A, 1) <> "*" And A.Value <> 0 And A.Offset(0, 1).Value = 0 Then
Changing that line to:
If True Then
And then changing:
f = A.Value
To:
f = "newbook"
Yields the following email being popped up for sending:
So there is no problem with your actual e-mail logic, just your workbook parsing logic.
Per updated comments
To automatically send the message change:
Set myAttachments = MItem.Attachments
With MItem
.To = EmailAddr
.Subject = Subj
.Display
End With
'paste the attachment of new workbooks save on user desktop
myAttachments.Add "D:\" & f & ".xlsx"
to:
Set myAttachments = MItem.Attachments
myAttachments.Add "D:\" & f & ".xlsx"
With MItem
.TO = EmailAddr
.Subject = Subj
.Display
.Send
End With
I think something like this work if you say MIem.send option
If GetOutlook = True Then
Set mItem = mOutlookApp.CreateItem(olMailItem)
mItem.Recipients.Add strRecip
mItem.Subject = strSubject
mItem.Body = strMsg
' This code allows for 1 attachment, but with slight ' modification, you could provide for multiple files.
If Len(strAttachment) > 0 Then
mItem.Attachments.Add strAttachment
End If
mItem.Save
mItem.Send
End If
I have an excel spreadsheet that select pre-defined cells and from this creates and email when a user presses a button. This worked fine when I had about 3 to 4 rows of data but now I have over 500 rows.
What I would like to do is instead of duplicating the code for each row is have one function that gets called on each time. I want the code to work out the row from a link at the end of the Row (which I also need to figure out how to link to the VBA, I know how to do it via a button but a link at the end of each row would be much better). The Link will say send email. If the user presses this link, then it will select the row the link is on and send the email. Hope that makes sense. I just wanted 1 function this could be called from. Instead of having to duplicate the code each time for each row.
Any good ways of doing this? Please see my code and spreadsheet below.
Sub SendEmail()
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
objEmail.Subject = Cells(2, 1).Text
objEmail.Body = "============" & vbNewLine & Cells(2, 3).Text & vbNewLine & "============" & vbNewLine & Cells(2, 6).Text
objEmail.To = Cells(2, 5).Text
objEmail.SentOnBehalfOfName = "test#test.com"
objEmail.Display
End Sub
I have also attached an example of my spreadsheet. Please note the full on spreadsheet has over 500 records. This is a much condensed version:
>> LINK to sample workbook
You can also try below:
Sub SendEmail(r As Range)
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.Subject = r.Value2
.Body = "============" & vbNewLine & r.Offset(0, 2).Value2 & vbNewLine & _
"============" & vbNewLine & r.Offset(0, 5).Value2
.To = r.Offset(0, 4).Value2
.SentOnBehalfOfName = "test#test.com"
.Display
End With
End Sub
Then test it:
Sub Test()
Dim lr As Long, cel As Range
With Sheets("SheetName")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
If lr = 1 Then Msgbox "No email to send": Exit Sub
For Each cel In .Range("A2:A" & lr)
SendEmail cel
Next
End With
End Sub
Edit: To send mail when hyperlink is pressed, you can use a worksheet event.
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.EnableEvents = False
On Error GoTo halt
If Target.Name = "Send Mail" Then '<~~ Check which hyperlink is pressed
'*** This will call the SendEmail routine above and pass
'*** the range where the hyperlink is on
'*** Take note of the Offset(0, -5). I just based it on your screen shot
'*** where your subject is 5 cells from the cell with Send mail
'*** Adjust it to your actual target range
Application.Run SendEmail, Target.Range.Offset(0, -5)
'SendEmail Target.Range.Offset(0, -5)
End If
moveon:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume moveon
End Sub
I used Application.Run so that you don't have to worry whether your SendEmail sub routine is Public or not. If you decide to just make it Public in a Module, you can use the commented line.
Use the row from the selection. Select your row, then get the row from the selected range, and use it in your code for the cells(iRow, 1)
Sub SendEmail()
Dim ActSheet As Worksheet
Dim SelRange As Range
Dim iRow As Integer
Set ActSheet = ActiveSheet
Set SelRange = Selection
iRow = SelRange.Row
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
objEmail.Subject = Cells(iRow , 1).Text
objEmail.Body = "============" & vbNewLine & Cells(iRow , 3).Text & vbNewLine & "============" & vbNewLine & Cells(iRow , 6).Text
objEmail.To = Cells(iRow , 5).Text
objEmail.SentOnBehalfOfName = "test#test.com"
objEmail.Display
End Sub
Here how you get all the rows and run your sub on all the rows.
Sub sendEmailFromAllRows()
'Getting the last used row
With Sheets("YourSheetName")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
End With
'Calling your sub to send the mail for each row
For i = 2 To lastrow
SendEmail (i)
Next i
End Sub
Sub SendEmail(iRow As Integer)
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
objEmail.Subject = Cells(iRow, 1).Text
objEmail.Body = "============" & vbNewLine & Cells(iRow, 3).Text & vbNewLine & "============" & vbNewLine & Cells(iRow, 6).Text
objEmail.To = Cells(iRow, 5).Text
objEmail.SentOnBehalfOfName = "test#test.com"
objEmail.Display
objEmail.Send
End Sub
I have the below code that I am trying to modify to split a subject line into to six columns to view in Excel.
Sub subject2excel()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
xlobj.Range("a" & i + 1).Value = myitem.Sender
xlobj.Range("b" & i + 1).Value = myitem.Subject
Next
End Sub
My data is in the below format
SLWP Moncton | Cable Service Eng. | 21-Jul-15 | Shift End: 0:00 | Leave Time: entire day | SLWP (Unpaid)
So in total 7 columns I plan to leave is below.
Sender
Location
LOB
Date
Shift End Time
Shift Leave Time
Leave Type
In it's current state as you can see it only produces two columns and I do not know how to break the subject line apart.
Any help will be most appreciated.
Thanks
Use Split.
Sub subject2excel()
Dim myOlApp As Outlook.Application
Dim myFolder As folder
Dim xlobj As Object
Dim i As Long
Dim j As Long
Dim myitem As Object
Dim Words() As String
'On Error Resume Next
Set myOlApp = Outlook.Application
'Set myNameSpace = myOlApp.GetNamespace("mapi")
Set myFolder = myOlApp.ActiveExplorer.currentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myFolder.Items.count
Set myitem = myFolder.Items(i)
If TypeOf myitem Is MailItem Then
'msgText = myitem.body
xlobj.Range("a" & i + 1).Value = myitem.Sender
'xlobj.Range("b" & i + 1).Value = myitem.Subject
Words = Split(myitem.Subject, " | ")
For j = 0 To UBound(Words)
Debug.Print Words(j)
Next j
End If
Next i
exitRoutine:
Set myOlApp = Nothing
Set myFolder = Nothing
Set xlobj = Nothing
Set myitem = Nothing
End Sub
I was able to solve the issue
Sub subject2excel()
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
Dim i As Long
Dim j As Long
Dim vSubject As Variant
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0 'err_Handler
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
'Set Heading
With xlWB.Sheets(1)
.Range("A" & 1).Value = "Sender"
.Range("B" & 1).Value = "Location"
.Range("C" & 1).Value = "LOB"
.Range("D" & 1).Value = "Date"
.Range("E" & 1).Value = "Shift End Time"
.Range("F" & 1).Value = "Requested Leave Time"
.Range("G" & 1).Value = "Paid/Unpaid"
End With
'Fill sheet
Set olNS = GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For i = 1 To olFolder.Items.Count
Set olItem = olFolder.Items(i)
If InStr(1, olItem.Subject, "|") > 0 Then
vSubject = Split(olItem.Subject, "|")
With xlWB.Sheets(1)
.Range("A" & i + 1).Value = olItem.Sender
.Range("B" & i + 1).Value = vSubject(0)
.Range("C" & i + 1).Value = vSubject(1)
.Range("D" & i + 1).Value = vSubject(2)
.Range("E" & i + 1).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1))
.Range("F" & i + 1).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1))
.Range("F" & i + 1).HorizontalAlignment = -4152 'align right
.Range("G" & i + 1).Value = Replace(Trim(Mid(vSubject(5), InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "")
End With
End If
Next i
xlWB.Sheets(1).UsedRange.Columns.Autofit
exitRoutine:
Set olFolder = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
err_Handler:
GoTo lbl_Exit
End Sub