Excel VBA Creation error - vba

I am attempting to write a macro to read a spreadsheet. Whenever someone is one year or later with a task, it will send their supervisor email.
I figured out how to send one email per person to a supervisor, but I wonder if I can scan all people and add them to one email. I tried to modify it, but I could not get it (this is my second day of VBA, hehe)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "E").Value) = "yes" _
And LCase(Cells(cell.Row, "H").Value) <> "send" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
If Cells(cell.Row, "E").Value = "YES" Then
.body = Cells(cell.Row, "B") & " " & Cells(cell.Row, "A")
.Send
On Error GoTo 0
Cells(cell.Row, "H").Value = "send"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

This is untested, but let me know how it works:
Sub test()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim bodyText As String 'this is new
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
bodyText = ""
On Error GoTo cleanup
For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And LCase(Cells(cell.row, "E").Value) = "yes" And LCase(Cells(cell.row, "H").Value) <> "send" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
If Cells(cell.row, "E").Value = "YES" Then
'The next line should add the text, and a new line character, so the next cell that needs this will simply be added to the string
bodyText = Cells(cell.row, "B") & " " & Cells(cell.row, "A") & vbCrLf
End If
End With
On Error GoTo 0
Cells(cell.row, "H").Value = "send"
Set OutMail = Nothing
End If
Next cell
OutMail.body = bodyText
OutMail.Send
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

Related

Replace content in oft template when sending through vba excel

I am trying to send mails automatically with an outlook template making minor changes to the text linked to the excel file. But the results do not appear when I choose an HTML format. Here is my code: I think the problem is with the .HTMLbody line because everything else in the code works fine. Could someone help?
Sub Test1()
'Working in Office 2000-2016
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("C:\Users\600008809\Desktop\Reminder emails\Initial Survey.oft")
On Error GoTo cleanup
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "H").Value) = "yes" _
And LCase(Cells(cell.Row, "I").Value) <> "send" Then
'Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "abc!"
.BodyFormat = olFormatHTML
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").Range(4, 2))
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
Set .SendUsingAccount = OutApp.Session.Accounts.Item("abc#xyz.com")
.Send
'.Display 'Or use Display
End With
On Error GoTo 0
Cells(cell.Row, "I").Value = "send"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This line is not good:
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").Range(4, 2)
You have to replace the range value, or cell value in here so you should use
.HTMLBody = Replace(.HTMLBody, "<< HiringManager >>", Worksheets("Tool").cells(4, 2).value

How to paste mulple excel range as picture to outlook at the same time

please help me fix this. I'm new to this area and I would like to paste multiple set of range from excel and paste it onto an outlook email with modified size. Please help me. Thanks in advance!
Here's my current code:
Sub EmailSend()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
StrBody = "Please see our current Report"
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "x"
.CC = "x"
.BCC = "x"
.Subject = "RRF for Vendor Sourcing - " & Cells(3, 2)
.HTMLBody = StrBody & RangetoHTML(rng)
.Display 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
This line of code is what defines your range.
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
You can simply define another range :
Dim rng2 As Range
Set rng2 = Range("J4:N8").SpecialCells(xlCellTypeVisible)
and then make another call to RangetoHTML() using that second range:
RangetoHTML(rng2)
which will return another string of html which you can then concatenate like this:
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & RangetoHTML(rng2)

failes to find "true" in mail to range macro

Got a macro from Ron de Bruin which I've been using, but now I can't get it to find the "TRUE" in the reference column. The "TRUE" is generated from checkboxes, it works if I write "yes" I've used the original code from his page, shown here:
Sub Test1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _ 'right value is being shown
LCase(Cells(cell.Row, "D").Value) = "TRUE" Then 'suddenly skips this phase.
'Shows the right row but nothing happens anymore
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
If I remove And _ LCase(Cells(cell.Row, "D").Value) = "TRUE" it works like a charm. I hope someone can help me out with this.
since the cell whose value you're querying is linked to a (ActiveX) checkbox its value is of a Boolean type
so you have to check it as such, that is:
If Cells(cell.Row, "D").Value Then 'means IF Cells(cell.Row, "D").Value = True
The following line is incorrect
LCase(Cells(cell.Row, "D").Value) = "TRUE" Then
you are converting the value to lowercase using the LCase function (eg true) ... you should change it to
UCase(Cells(cell.Row, "D").Value) = "TRUE" Then

Adding email sent status to Excel

I use Excel to send monthly statements to our brokers. Is there a way to add a column to show if each of the individual email is actually sent.
Some of the rows might have an invalid email address and the only way I can tell if all of them are sent is by going through my sent folder.
Sub SendEmails()
Dim answer As Variant
answer = MsgBox("You are about to send the statements. Proceed?", vbYesNo + vbQuestion, "Alert")
Select Case answer
Case vbYes
MsgBox "Process may take a while to finish. Do not attempt to close the worksheet or Outlook.", vbInformation, "Alert"
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Listing")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("D").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("A1:B1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Statement of Account - " & cell.Offset(0, 2).Value
.Body = cell.Offset(0, 1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Case vbNo
GoTo Quit:
End Select
Quit:
End Sub
Why not just Resolve each Recipient's email before sending
eg:
For Each olRecip In .Recipients
olRecip.Resolve
If Not olRecip.Resolve Then
olMsg.Display
End If

Send Mail with email address in 4 columns

I send email with Ron de Bruin's script where it has option for sending of email address from column B value.
I have at least 4 columns of email address from column B to E. How can I modify this to send this e-mail?
Example:
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this: C:\Data\Book2.xls (doesn't have to be Excel files)
The macro will loop through each row in Sheet1 and if there is an e-mail address in column B and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
MASSIVE EDIT
As per your comment, the code below is changed. Should be working under the assumption that there is a filename in Column F. The lines to remove/comment out are marked in the code below in case you don't want this requirement.
Private Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'--BK201 mod: http://stackoverflow.com/questions/20776481/send-mail-with-email-address-in-4-columns--'
Dim OutApp As Object
Dim OutMail As Object
Dim Sh As Worksheet
Dim FileCell As Range
Dim Rec As Range, RecRng As Range, RecList As Range, RecMail As Range
Dim FileRng As Range
Dim RecStr As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Sh = ThisWorkbook.Sheets("Sheet1")
Set RecList = Sh.Range("B:B")
Set OutApp = CreateObject("Outlook.Application")
For Each Rec In RecList
With Sh
Set RecRng = .Range("B" & Rec.Row & ":E" & Rec.Row)
Set FileRng = .Range("F" & Rec.Row)
End With
RecStr = ""
For Each RecMail In RecRng
If RecMail.Value Like "?*#?*.?*" Then
RecStr = RecStr & RecMail.Value & ";"
End If
Next RecMail
If Len(FileRng.Value) > 0 Then '--Comment out if alright to send without attachment.
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = RecStr
.Subject = "Testfile"
.Body = "Hi " & Rec.Offset(0, -1).Value
On Error Resume Next
For Each FileCell In FileRng
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display '.Send
End With
Set OutMail = Nothing
Else '--Comment out if alright to send without attachment.
Exit For '--Comment out if alright to send without attachment.
End If '--Comment out if alright to send without attachment.
Next Rec
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Set-up:
Result:
Hope this helps. :)