Excel VBA - create Outlook appointment with Eastern Time Zone - excel

I have an Excel macro which creates an Outlook appointment. I can make everything work except I need to set the Time Zone as "Eastern". Some of my co-workers live in other time zones and I want to make sure the appointment is set at the correct time for them. Here is the code I currently have. How do I set the time zone to Eastern (US & Canada)?
Set objOL = CreateObject("Outlook.Application")
Set objItem = objOL.CreateItem(1)
With objItem
.StartTimeZone = "Eastern"
.Start = Range("B4").Text & " " & Range("C4").Text
.End = Range("B4").Text & " " & Range("D4").Text
.Body = "Centra Link: " & Range("K4") & vbCrLf & vbCrLf & " Phone: " & Range("I4") & vbCrLf & vbCrLf & "Lead facilitator: " & Range("E4") & vbCrLf & "Co-facilitator: " & Range("F4") & vbCrLf & vbCrLf & Range("MISC_HEADER") & ": " & Range("H4")
.Location = Range("I4") & ", Leader Code: " & Range("J4")
.alldayevent = False
.Subject = Range("A4")
.ReminderMinutesBeforeStart = 30
.ReminderSet = True
.Save
End With
Set objItem = Nothing
Set objOL = Nothing
MsgBox "An appointment has been created for " & Range("A4") & " on " & Range("B4"), vbOKOnly, "Calendar Appointment"

It is not that easy, as to say
.StartTimeTone = "Eastern"
look here: http://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._appointmentitem.starttimezone.aspx
you see, you would have to create a TimeZone object, like here
How to Modify Properties (Time Zone) of Recurring Appointments in Outlook 2010 VBA
look at the answear of siddharth rout.

Related

Extract CurrentRegion into email body

CurrentRegion is extracted but not shown in email body
Sub Draft()
Dim myDataRng As Range
Set myDataRng = Range("c2:c2")
Dim data As String
data = Range("B11").CurrentRegion.Select
For Each Cell In myDataRng
If Cell.Value > 0 Then
Dim objOutlook As Object
Set objOutlook = CreateObject("outlook.application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Range("K2").Select
With objEmail
.SentOnBehalfOfName = "accounting#test.co.uk"
.to = ActiveCell.Offset(0, 1).Value
.Subject = ActiveCell.Offset(7, 0).Value
.htmlbody = "Supplier Code " & " " & Cell.Offset(0, 0).Value & "<br>" & "Supplier Name: " & " " & Cell.Offset(1, 0).Value & "<br>" & "Currency " & " " & Cell.Offset(2, 0).Value & "<br>" & "<br>" & "Dear Supplier," & "<br>" & "<br>" & "A payment has been issued to you, as detailed below. " & "<br>" & data & "<br>" & "<br>" & "Kind Regards,<br>Johnny Grif <br>Accounts Assistant/Accounts Department" & "<br>" & "T:+44(0)1234 567 890" & "<br>" & "E:accounting#test.co.uk"
.Save
End With
Set objOutlook = Nothing
End If
Next Cell
Set myDataRng = Nothing
Set objEmail = Nothing: Set objOutlook = Nothing
MsgBox "Please check pyament advice in your draft folder!"
End Sub
The final outcome is like this.
Dear Supplier,
A payment has been issued to you, as detailed below.
True
Kind Regards,
Johnny Grif
Accounts Assistant/Accounts Department
T:+44(0)1234 567 890
E:accounting#test.co.uk
Below is the output:
The following code is the cause of the problem:
.htmlbody = "Supplier Code " & " " & Cell.Offset(0, 0).Value & "<br>" & "Supplier Name: " & " " & Cell.Offset(1, 0).Value & "<br>" & "Currency " & " " & Cell.Offset(2, 0).Value & "<br>" & "<br>" & "Dear Supplier," & "<br>" & "<br>" &
"A payment has been issued to you, as detailed below. " & "<br>" & data & "<br>" & "<br>" & "Kind Regards,<br>Johnny Grif <br>Accounts Assistant/Accounts Department" & "<br>" & "T:+44(0)1234 567 890" & "<br>" & "E:accounting#test.co.uk"
First of all, the message body markup should be represented by a well formed HTML document/string.
Second, if you need to break the line in the code you need to use the underscore _ character in the code to get the lines assembled correctly.
Third, I'd suggest breaking the code and trying to assemble the final from multiple pieces, so you could find out why the code doesn't work correctly.

Worksheet_Calculate repeats until I force quit Excel

I have a working VBA script that generates an Outlook email when cell value = 1. This runs on a hidden worksheet (cell is changed to 1 when criteria is met on visible summary worksheet).
Dim xRg As Range
'Update by Extendoffice 2019/8/2
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("AA1"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value = 1 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hello " & Range("G2") & "," & vbNewLine & vbNewLine & _
"Please review the following list of loan documents that were produced through our online system from " & Range("A2") & ". Your total bill for this month's documents is " & FormatCurrency(Range("E2")) & " (" & Range("C2") & " x " & Range("D2") & "):" & vbNewLine & vbNewLine & _
Range("F2") & vbNewLine & _
Range("F3") & vbNewLine & _
Range("F4") & vbNewLine & _
Range("F5") & vbNewLine & _
Range("F6") & vbNewLine & _
Range("F7") & vbNewLine & _
Range("F8") & vbNewLine & _
Range("F9") & vbNewLine & _
Range("F10") & vbNewLine & _
Range("F11") & vbNewLine & _
Range("F12") & vbNewLine & _
Range("F13") & vbNewLine & _
Range("F14") & vbNewLine & _
Range("F15") & vbNewLine & _
Range("F16") & vbNewLine & _
Range("F17") & vbNewLine & _
Range("F18") & vbNewLine & _
Range("F19") & vbNewLine & _
Range("F19") & vbNewLine & _
Range("F20") & " " & Range("F21") & " " & Range("F22") & " " & Range("F23") & " " & Range("F24") & " " & Range("F25") & " " & Range("F26") & " " & Range("F27") & " " & Range("F28") & " " & Range("F29") & " " & Range("F30") & " " & Range("F31") & " " & Range("F32") & " " & Range("F33") & " " & Range("F34") & " " & Range("F35") & " " & Range("F36") & " " & Range("F37") & " " & Range("F38") & " " & Range("F39") & " " & Range("F40") & " " & Range("F41") & " " & Range("F42") & " " & Range("F43") & " " & Range("F44") & " " & Range("F45") & " " & Range("F46") & " " & Range("F47") & " " & Range("F48") & " " & Range("F49") & " " & Range("F50") & " " & Range("F51") & " " & Range("F52") & " " & Range("F53") & " " & Range("F54") & " " & vbNewLine & _
Range("F55") & " " & Range("F56") & " " & Range("F57") & " " & Range("F58") & " " & Range("F59") & " " & Range("F60") & " " & Range("F61") & " " & Range("F62") & " " & Range("F63") & " " & Range("F64") & " " & Range("F65") & " " & Range("F66") & " " & Range("F67") & " " & Range("F68") & " " & Range("F69") & " " & Range("F70") & " " & Range("F71") & " " & Range("F72") & " " & Range("F73") & " " & Range("F74") & " " & Range("F75") & " " & Range("F76") & " " & Range("F77") & " " & Range("F78") & " " & Range("F79") & " " & Range("F80") & " " & Range("F81") & " " & Range("F82") & " " & Range("F83") & " " & Range("F84") & " " & Range("F85") & " " & Range("F86") & " " & Range("F87") & " " & Range("F88") & " " & Range("F89") & " " & vbNewLine & vbNewLine & _
"Please let us know within two business days whether your records match ours. If we do not get a response within this time frame, we will invoice you shortly thereafter. If your credit card is on file and we have a pre-existing authorization, we will charge your card on file and provide you with a copy of your paid invoice." & vbNewLine & vbNewLine & _
"Thank you!" & vbNewLine
On Error Resume Next
With xOutMail
.To = Range("H2")
.CC = "billing#example.com"
.BCC = ""
.Subject = Range("B2") & " - (ID: " & Range("I2") & ") - " & Range("A2") & " Lightning Docs Usage & Billing"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Private Sub Worksheet_Calculate()
Dim xI As Integer
Dim xRg As Range
Set xRg = Range("AA1")
On Error GoTo Err01
xI = Int(xRg.Value)
If xI = 1 Then
Call Mail_small_Text_Outlook
End If
Err01:
End Sub
This is a bodge way of adding what should be a table into the email body.
I recently discovered Ron de Bruin's script for converting a table to HTML and adding it to an email body that way. I got the script running, but my problem comes when trying to trigger the macro from another worksheet. The user will be on the summary worksheet and make a change to cause cell AA1 on the VBA script worksheet to change to 1.
Without Private Sub Worksheet_Calculate(), it works when I am on the worksheet with the script.
When I add Private Sub Worksheet_Calculate(), it can be triggered from a different worksheet, but it gets stuck at the point where a temporary worksheet is created, and keeps creating temporary worksheets until I force quit Excel.
Dim xRg As Range
'Update by Extendoffice 2018/3/7
Public Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("AA1"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 0 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
On Error Resume Next
With xOutMail
.To = Range("H2")
.CC = "billing#example.com"
.BCC = ""
.Subject = Range("C2") & " - (ID: " & Range("I2") & ") - " & Range("B2") & " Lightning Docs Usage & Billing"
.HTMLBody = "<font size=-0> Hello " & Range("G2") & ",<br/><br/>" &
"Please review the following list of loan documents that were produced through our online system from " & Range("B2") & ". <br/>Your total bill for this month's documents is " & FormatCurrency(Range("F2")) & " (" & Range("E2") & " x " & FormatCurrency(Range("D2")) & "):</font>" &
RangetoHTML(Range("Table3_2[Titles]")) &
"<br/><font size=-0>Please let us know within two business days whether your records match ours. If we do not get a response within this time frame, we will invoice you shortly thereafter. If your credit card is on file and we have a pre-existing authorization, we will charge your card on file and provide you with a copy of your paid invoice." &
"<br/><br/>Thank you!</font><br/>"
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Private Sub Worksheet_Calculate()
Dim xI As Integer
Dim xRg As Range
Set xRg = Range("AA1")
On Error GoTo Err01
xI = Int(xRg.Value)
If xI = 1 Then
Call Mail_small_Text_Outlook
End If
Err01:
End Sub

How to attach a file to a MailItem

I'm trying to automate creation of an email with a user required to press Send so it can be checked. I can get the mail item created with a 'To' list and such, however when I try to add an attachment I get an error.
Sub EmailReportX(ByVal MailTo As String, AttachFilename As String, AttachFilePath As String, SubjectDate As String)
Dim objOutlook As Object
Dim objMailItem As Object
Dim strAtt As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(olMailItem)
strAtt = AttachFilePath & AttachFilename
With objMailItem
.To = MailTo
.Subject = "Seymour Horst Daily Completions Report " & SubjectDate
.body = "Morning," & vbCrLf & vbCrLf & "Daily completions report for review" & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & "Tim C"
.Attachments.Add = strAtt
.display
End With
Debug.Print strAtt
End Sub
.Attachments.Add() is a method and thus does not require the equals sign.
https://learn.microsoft.com/en-us/office/vba/api/outlook.attachments.add
so use it like this.
With objMailItem
.To = MailTo
.Subject = "Seymour Horst Daily Completions Report " & SubjectDate
.body = "Morning," & vbCrLf & vbCrLf & "Daily completions report for review" & vbCrLf & vbCrLf & "Regards" & vbCrLf & vbCrLf & "Tim C"
.Attachments.Add strAtt
.display
End With

Input cell data from Excel into Outlook

I'm looking to make an automated email script using vba to read from an Excel spreadsheet; the email address and dates (that sort of thing) then place them into the correct fields to send
It would be preferable if it could also finish the line of the spreadsheet and start a new one with a new email
I can currently make an email with vba but that's about it and manually dictate the fields within the script but that's about it. Any help on how to input cell data automatically would be much appreciated.
Thanks :)
Edit 1:
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & Range("C" & Line).Value & " " & Range("B" & Line).Value & " - " & Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & Range("C" & Line).Value & " " & Range("B" & Line).Value & "'s appointment with Dr " & Range("E" & Line).Value & " on " & Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub
This seems to be the solve in case anyone has the same issue.
Thanks
The below code is more specific when defining the cells, which worked during my testing.
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = ws.Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & " - " & ws.Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & ws.Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & "'s appointment with Dr " & ws.Range("E" & Line).Value & " on " & ws.Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub

Adding an If Statement into Html e-mail text in excel VBA

I am trying to add in an if statement half way through a HTML body of text I am using in VBA to send an e-mail.
I need to work out how to get the code to add extra hyperlinks if a cell in on one of the tabs has a value, there could be up to five that may need to be added.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = Accounts
.Subject = "Consolidated Account Statement " & myPolicynumber & " - " & mypolicyname
If myhyperlink2 = "" Then
.HTMLBody = "<HTML><BODY>" & "<FONT-size=""11.0pt"">" & "Hi Accounts" & "<br><br>" & _
" The Account Statement" & _
" for " & myPolicynumber & " (" & mypolicyname & ") is ready to be created. " & "<br><br>" & "<br><br>" & _
" The following Medical Extra Premium also need booking " & "<br><br>"
If Worksheets("FOR PA").Cells(13, 39).Value = "Medicals" Then
" Medical Extra Premium 1" & "<br><br>" & _
" Medical Extra Premium 2" & "<br><br>" & _
" Medical Extra Premium 3" & "<br><br>" & _
" Medical Extra Premium 4" & "<br><br>" & _
" Medical Extra Premium 5" & "<br><br>" & _
" Kind Regards," &.HTMLBody
.Send
Else
.HTMLBody = "<HTML><BODY>" & "<FONT-size=""11.0pt"">" & "Hi Accounts" & "<br><br>" & _
" The Initial" & " and the " & "Final & are ready to be put on the Account Statement " & _
" for " & myPolicynumber & " (" & mypolicyname & ") is ready to be created. " & "<br><br>" & _
" Kind Regards," & .HTMLBody
.Send
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
You're doing the right thing, but you're missing a .HTMLBody = before one of the options:
If Worksheets("FOR PA").Cells(13, 39).Value = "Medicals" Then
.HTMLBody = " Medical Extra Premium 1" & "<br><br>" & _
" Medical Extra Premium 2" & "<br><br>" & _

Resources