I have code that works fine in all aspects, but I can not find a way to create a hyperlink in an Outlook appointment. The address is placed in column H in Excel, and I want to use VBA to export it to a certain calendar. Any help would greatly be appriciated.
My code is as follows:
Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Dim miCalendario As Object
Dim r As Long
On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0
If Not OLApp Is Nothing Then
Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon "Outlook"
b = 1
r = 2
Dim mysub, myStart, myEnd, mydes, myallday
While Len(Cells(r, 5).Text) <> 0
mysub = Cells(r, 7)
If Not Cells(r, 13).Value = 0 Then
mysub = mysub & "(s. " & Cells(r, 13).Value & ")" & vbCrLf
End If
'& ", " & Cells(r, 3)
myStart = DateValue(Cells(r, 1).Value) + Cells(r, 2).Value
myEnd = DateValue(Cells(r, 1).Value) + Cells(r, 3).Value
mydes = ""
Set miCalendario = OLApp.Session.GetDefaultFolder(9).Folders(ActiveSheet.Name)
Set OLAppointment = miCalendario.Items.Add(olAppointmentItem)
Dim olItems As Items
Dim olApptItem As Outlook.AppointmentItem
Set olItems = miCalendario.Items
Set olApptItem = miCalendario.Items.GetFirst
'add appointments
On Error Resume Next
With OLAppointment
.Subject = mysub
.Start = myStart
.End = myEnd
.Body = mydes
If Not Cells(r, 1).Value = 0 Then
If Not Cells(r, 8).Value = 0 Then
mydes = mydes & Cells(1, 8).Value & " - " & Cells(r, 8).Value & vbCrLf
End If
.Body = mydes
End If
.Location = Cells(r, 4).Value .Save
End With
r = r + 1
b = b + 1
Wend
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If
End Sub
You need to use .HTMLBody insted .Body
.HTMLbody = "link_Mask"
I hope it'll help
Related
I am trying to create a macro to send automated reminders.
I am sending below the two macros:
Sub Auto_Open()
Dim vResp As Variant, dTime As Date
vResp = MsgBox("Inviare email ora?", vbYesNo)
If vResp = 6 Then 'YES
Call EmailReminder
ElseIf vResp = 7 Then 'NO
dTime = CDate(InputBox("Send email at:", , Time + TimeValue("00:00:10")))
Do Until Time = dTime 'OR = #8:00:00 AM#
DoEvents
Loop
Call EmailReminder
End If
End Sub
Sub EmailReminder()
Dim oOL As Outlook.Application, oMail As Outlook.MailItem, oNS As Outlook.Namespace
Dim oMapi As Outlook.MAPIFolder, oExpl As Outlook.Explorer
Dim sBody As String, dDate As Date
Dim oWS As Worksheet, r As Long, i As Long, sStart As String
Set oWS = Foglio1
Set oOL = New Outlook.Application
Set oExpl = oOL.ActiveExplorer
If TypeName(oExpl) = "Nothing" Then
Set oNS = oOL.GetNamespace("MAPI")
Set oMapi = oNS.GetDefaultFolder(olFolderInbox)
Set oExpl = oMapi.GetExplorer
End If
With oWS.Range("E1")
r = .CurrentRegion.Rows.Count
For i = 1 To r
dDate = .Cells(i, 1)
sBody = "Oggi è il compleanno di" & .Cells(i, 2) & dDate & .Cells(i, -4) & " " & .Cells(i, -3) & vbCrLf & "Facciamo i nostri auguri!"
If Date = dDate Or Date = Int(dDate) Then ' Use INT to eliminate time info
Set oMail = oOL.CreateItem(oIMailItem)
With oMail
.Recipients.Add "umberto.roselli#openfiber.it" 'Indirizzo ricevente
.Subject = "Nuovo compleanno oggi:" & .Cells(i, -4) & " " & .Cells(i, -3) & .Body = sBody: .Send
End With
End If
Next i
End With
MsgBox "Messaggio email inviato correttamente!"
End Sub
I keep getting, however, on the second macro the error Run-Time 13: Type not matching but it doesn't give me any indication where the error is.
Can you help me out?
Thank you very much in advance
Fyi
Private Sub Workbook_Open()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
For i = 2 To Range("e65536").End(xlUp).Row
If Cells(i, 8) <> "Y" Then
If Cells(i, 5) - 7 < Date Then
strto = Cells(i, 7).Value 'email address
strsub = Cells(i, 1).Value & " " & Cells(i, 2).Value & " compleanno il " & Cells(i, 5).Value 'email subject
strbody = "Il compleanno di " & Cells(i, 1).Value & " " & Cells(i, 2).Value & " sarà il " & Cells(i, 5).Value & vbNewLine 'email body
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Send
End With
Cells(i, 8) = "Mail Sent " & Now()
Cells(i, 9) = "Y"
End If
End If
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I am trying to send an email with the below code from my workbook. It works fine but only until I try to attach a file.
The file is created by another VBA code and the file name is defined by the cell values specified below, but I get a debug error when I try to run the code and it won't attach. I've tested with a named path eg C:test\test.docx and it works fine.
How can I get it to accept the path based on the cell values? I've set it to .Display whilst testing rather than send.
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub SendEmail()
Dim objOutlook As Object
Dim objMail As Object
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim path As String
path = "\\Wbcphfil01.wbc.lan\dts\Groups\Operational_Services\opserv_group\Enforcement\NRSWA\Licences\Mobile Plant\Applications 2019-20\" & Cells(i, 4) & " (" & Cells(i, 13) & ").docx"
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 7)
If .Value <> "" And Cells(i, 5) = "Mobile Plant" Then
With objMail
.To = Cells(i, 11).Value
.Subject = "Your " & Cells(i, 5).Value & " licence - " & Cells(i, 4).Value
.Body = "abc"
.Attachments.Add path
.Display
End With
End If
End With
Next i
Set objOutlook = Nothing
Set objMail = Nothing
End Sub
You are using Cells(i, 4) on the path to the file before you defined what the variable i actually is! Maybe move the path inside your For Loop?
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub SendEmail()
Dim objOutlook As Object
Dim objMail As Object
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim path As String
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
path = "\\Wbcphfil01.wbc.lan\dts\Groups\Operational_Services\opserv_group\Enforcement\NRSWA\Licences\Mobile Plant\Applications 2019-20\" & Cells(i, 4) & " (" & Cells(i, 13) & ").docx"
With Cells(i, 7)
If .Value <> "" And Cells(i, 5) = "Mobile Plant" Then
With objMail
.To = Cells(i, 11).Value
.Subject = "Your " & Cells(i, 5).Value & " licence - " & Cells(i, 4).Value
.Body = "abc"
.Attachments.Add path
.Display
End With
End If
End With
Next i
Set objOutlook = Nothing
Set objMail = Nothing
End Sub
This should be straight-forward but I somehow can't get it right. I am trying to set-up an automatic email blast from Excel. I have followed step by step the instructions from other posts here, with no success. This is a dummy example I've created, for the sake of simplicity.
I would like to:
send emails to everybody in the list
conditionally replace certain keywords in the body
populate a column with the delivery status for each email (sent/failed)
My current code sends the email only to the first person in the list. I've used my personal email address for testing purposes. I wonder if sending the emails to the same address could be the issue. If anybody can provide some guidance, would be much appreciated!
Sub SendMail()
Dim EmailSent, EmailFailed, i As Integer
Dim StatusSent, StatusFailed As String
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
EmailSent = 0
EmailFailed = 0
StatusFailed = "failed"
StatusSent = "sent"
i = 1
Do
DoEvents
With olMail
.To = Cells(i, 1).Value
.Subject = "test"
.CC = ""
.BCC = ""
.Importance = olImportanceHigh
.BodyFormat = olFormatHTML
.HTMLBody = Cells(i, 2).Value
If Cells(i, 3) = 1 Then
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
Else
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
End If
.send
End With
On Error Resume Next
olMail.send
If Err Then
EmailFailed = EmailFailed + 1
ActiveSheet.Cells(i, 6).Value = StatusFailed 'change status from pending to failed
Else
EmailSent = EmailSent + 1
ActiveSheet.Cells(i, 6).Value = StatusSent 'change status from pending to sent
End If
i = i + 1
Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count
If EmailSent = 0 Then
MsgBox Prompt:="Emails could not be sent"
Else
MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
& "Failed emails: " & EmailFailed
End If
On Error GoTo 0
Set olApp = Nothing
Set olMail = Nothing
End Sub
You're missing two crucial lines in your Do loop:
Set olMail = olApp.CreateItem(olMailItem)
and at the end:
Set olMail = Nothing
Try this instead:
Sub SendMail()
Dim EmailSent, EmailFailed, i As Integer
Dim StatusSent, StatusFailed As String
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
EmailSent = 0
EmailFailed = 0
StatusFailed = "failed"
StatusSent = "sent"
i = 1
Do
DoEvents
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = Cells(i, 1).Value
.Subject = "test"
.CC = ""
.BCC = ""
.Importance = olImportanceHigh
.BodyFormat = olFormatHTML
.HTMLBody = Cells(i, 2).Value
If Cells(i, 3) = 1 Then
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
Else
.HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
End If
.send
End With
On Error Resume Next
olMail.send
If Err Then
EmailFailed = EmailFailed + 1
ActiveSheet.Cells(i, 6).Value = StatusFailed 'change status from pending to failed
Else
EmailSent = EmailSent + 1
ActiveSheet.Cells(i, 6).Value = StatusSent 'change status from pending to sent
End If
Set olMail = Nothing
i = i + 1
Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count
If EmailSent = 0 Then
MsgBox Prompt:="Emails could not be sent"
Else
MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
& "Failed emails: " & EmailFailed
End If
On Error GoTo 0
Set olApp = Nothing
End Sub
Below is code I have written to automate sending meeting invites.
The code picks content from cells in sheet: Final_List.
I have highlighted where I'm getting an error when I try get the recipient address from Excel
Application -defined or object - defined error.
Dim outlookApp As Outlook.Application
Dim outlookmeet As AppointmentItem
Dim myRequiredAttendee As Recipient
Dim sh As Worksheet
Dim RowCount As Long
RowCount = 2
'row 1 has headers
With Worksheets("Final_List")
Do While IsEmpty(Cells(RowCount, 1).Value) = False
Set outlookApp = CreateObject("Outlook.Application")
Set outlookmeet = outlookApp.CreateItem(olAppointmentItem)
With outlookmeet
.MeetingStatus = olMeeting
.Subject = Cells(RowCount, 1).Value & " - " & Cells(RowCount, 2).Value
.Location = Cells(RowCount, 3).Value
.Start = Cells(RowCount, 5).Value
.Duration = Cells(RowCount, 7).Value
'getting errors on this line
.Recipients.Add (Cells(RowCount, 6).Value)
.Recipients.ResolveAll
.Body = Cells(RowCount, 4).Value
.Send
End With
RowCount = RowCount + 1
Loop
End With
Set outlookmeet = Nothing
Set outlookApp = Nothing
MsgBox "All invites sent!"
The AppointmentItem object doesn't have a Recipient property. Compare MSDN library
I got this solution:
Sub ScheduleMeeting()
Dim outlookApp As Outlook.Application
Dim outlookmeet As Outlook.AppointmentItem
Dim RowCount As Long
Dim Name1 As Variant
RowCount = 2
'row 1 has headers
Worksheets("MeetingInvite").Activate
With Worksheets("MeetingInvite")
Do While IsEmpty(Cells(RowCount, 1).Value) = False
Set outlookApp = CreateObject("Outlook.Application")
Set outlookmeet = outlookApp.CreateItem(olAppointmentItem)
With outlookmeet
.MeetingStatus = olMeeting
.Subject = Cells(RowCount, 1).Value
.Location = Cells(RowCount, 2).Value
.Start = Cells(RowCount, 4).Value
.Duration = Cells(RowCount, 6).Value
.RequiredAttendees = Cells(RowCount, 5).Value
.Body = Cells(RowCount, 3).Value
.Display
End With
RowCount = RowCount + 1
Loop
End With
Set outlookmeet = Nothing
Set outlookApp = Nothing
'MsgBox "All invites sent!"
End Sub
So far i have got working a macro to send out emails to everyone in my excel list and it works fine except i need to add a couple more things to it:
1, Send the email to people ONLY if the date in Cells(r, 4).Value is between Today + 7 days and Today + 14 days otherwise skip that row.
2, If email has been sent change value of Cells(r, 20).Value from "False" to "True"
3, Skip rows were Cells(r, 20).Value is "True"
Heres how it loos so far:
Sub SetupAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
DeleteNotices ' deletes previous test appointments
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
r = 10 ' first row with data in
While Len(Cells(r, 1).Formula) > 0
Set olAppItem = olApp.CreateItem(olAppointmentItem)
With olAppItem
.MeetingStatus = olMeeting
' set default appointment values
.Start = Now
.End = Now
.Subject = "No subject"
.Location = ""
.Body = ""
.ReminderSet = True
On Error Resume Next
.Recipients.Add Cells(r, 3).Value
.Recipients.ResolveAll
.Start = Cells(r, 4).Value + Cells(r, 5).Value
.End = Cells(r, 4).Value + Cells(r, 6).Value
.Subject = "Interview"
.Location = Cells(r, 13).Value + ", " + Cells(r, 14).Value
.Body = "Hi.... Blah Blah Blah"
.ReminderMinutesBeforeStart = 30
.Categories = "Notice"
On Error GoTo 0
.Save
.Display
'.Send
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
End Sub
Hope you can Help, Thanks in advance!
Rather than write the code for you here's what you do:
Get the content of Cells(r, 4) and use CDate to convert it to a date. Compare it to your start and end dates and if its in the range, continue.
Get content of (r, 20) and use CBool to get the bool value. Check and if OK continue.
After sending the email, just set Cells(r, 20) = true
Try that and see how it goes.