PDA

View Full Version : Using different Range in the body of email based on row criteria - Appointments



aravindhan_3
01-24-2017, 03:27 AM
Hi,
I Have this email macro which works perfectly for blocking appointments based on the data in each row in excel , given the complete code below, I need your help to change this line



.Body = Cells(i, 21)


instead of taking body from one cell, I have 3 tabs stored in the same file called " Face to Face", 'Telephonic" & "Tele Presence" with different content.
all these will be differentiated in the excel file in column Z, so the macro should check the value in column Z if Face to Face then use that content as body and same for other 2.


complete code below


Public Sub Block_Calendar()
Sheets("Email").Select
On Error GoTo Err_Execute

Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace
Dim CalFolder As Outlook.MAPIFolder
Dim rng As Range
Set rng = Sheets("Calendar").UsedRange


Dim i As Long

On Error Resume Next
Set olApp = Outlook.Application

If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If

On Error GoTo 0

Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)

i = 11
Do Until Trim(Cells(i, 4).Value) = ""

Set olAppt = CalFolder.Items.Add(olAppointmentItem)
With olAppt
.MeetingStatus = olMeeting
'Define calendar item properties
.Subject = Cells(i, 6)

' doni use location if using a resource
' .Location = Cells(i, 2)
.Body = Cells(i, 21)
' .Attachments.Add Cells(i, 14).Value
.Categories = Cells(i, 7)
.Start = Cells(i, 13) + Cells(i, 14) '+ TimeValue("9:00:00")
.End = Cells(i, 13) + Cells(i, 15) '+TimeValue("10:00:00")
.BusyStatus = olBusy
' .ReminderMinutesBeforeStart = Cells(i, 12)
.ReminderSet = True
' get the recipients
Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient
Set RequiredAttendee = .Recipients.Add(Cells(i, 13).Value)
RequiredAttendee.Type = olRequired
' Set OptionalAttendee = .Recipients.Add(Cells(i, 13).Value)
' OptionalAttendee.Type = olOptional
'Set ResourceAttendee = .Recipients.Add(Cells(i, 14).Value)
' ResourceAttendee.Type = olResource
' For meetings or Group Calendars
.Display

End With

i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing

Exit Sub

Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."

End Sub


Thanks for your help

mancubus
01-24-2017, 02:37 PM
post your workbook as explained in my signature.

aravindhan_3
01-25-2017, 07:53 AM
Attached the sample workbook.

thanks:)

mancubus
01-25-2017, 02:58 PM
which cell(s) from corresponding sheets (acc to col Z) should be returned as .Body?

aravindhan_3
01-26-2017, 01:09 AM
Thanks:) and sorry for missing this info.

Used Range from those sheets

Regards
Arvind

mancubus
01-26-2017, 01:51 PM
review your dates abd times in related columns. because you are adding two dates.

change

.Body = Cells(i, 21)
to

.Body = RangetoHTML(Worksheets(Cells(i, 26).Value).UsedRange.SpecialCells(xlCellTypeVisible))

but i would code it like:


Public Sub vbax_58355_create_outlook_appointments_based_on_criteria()

Dim i As Long

Sheets("Email").Select

On Error GoTo Err_Execute

With CreateObject("Outlook.Application")
With .GetNamespace("MAPI")
With .GetDefaultFolder(olFolderCalendar)
For i = 11 To Cells(Rows.Count, 4).End(xlUp).Row
With .Items.Add(olAppointmentItem)
.MeetingStatus = olMeeting
.Subject = Cells(i, 6)
'.Location = Cells(i, 2)
.Body = RangetoHTML(Worksheets(Cells(i, 26).Value).UsedRange.SpecialCells(xlCellTypeVisible))
'.Attachments.Add Cells(i, 14).Value
.Categories = Cells(i, 7)
.Start = Cells(i, 13) + Cells(i, 14) '+ TimeValue("9:00:00")
.End = Cells(i, 13) + Cells(i, 15) '+TimeValue("10:00:00")
.BusyStatus = olBusy
'.ReminderMinutesBeforeStart = Cells(i, 12)
.ReminderSet = True
.Recipients.Add(Cells(i, 12).Value).Type = olRequired
.Display
End With
Next i
End With
End With
End With

Exit Sub

Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."

End Sub


and the udf will be:


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
Dim AppRefStyle As Long

With Application
AppRefStyle = .ReferenceStyle
.ReferenceStyle = xlA1
End With

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

With Application
.ReferenceStyle = AppRefStyle
End With

End Function



this udf works fine with emails but i never tried with appointments...

aravindhan_3
01-27-2017, 06:13 AM
Hi,

Thanks a lot!,

1. IF i change to
.Body = RangetoHTML(Worksheets(Cells(i, 26).Value).UsedRange.SpecialCells(xlCellTypeVisible))


code creating the below html code as body



<html xmlns:o="urn:schemas-microsoft-com:office:office"
xmlns:x="urn:schemas-microsoft-com:office:excel"
xmlns="http://www.w3.org/TR/REC-html40">
<head>
<meta http-equiv=Content-Type content="text/html; charset=windows-1252">
<meta name=ProgId content=Excel.Sheet>
<meta name=Generator content="Microsoft Excel 15">
<link rel=File-List href="27-01-17%2018-39-51_files/filelist.xml">
<style id="Sheet2_10830_Styles">
<!--table
{mso-displayed-decimal-separator:"\.";
mso-displayed-thousand-separator:"\,";}
.xl1510830
{padding-top:1px;
padding-right:1px;
padding-left:1px;
mso-ignore:padding;
color:black;
etc...


2. new code stops and give error message after this


With CreateObject("Outlook.Application")
With .GetNamespace("MAPI")
With .GetDefaultFolder(olFolderCalendar)
For i = 11 To Cells(Rows.Count, 4).End(xlUp).Row
With .Items.Add(olAppointmentItem)
.MeetingStatus = olMeeting
.Subject = Cells(i, 6)


can u help me with this please.
Regards
Arvind

mancubus
01-27-2017, 01:24 PM
thanks to google...



Public Sub vbax_58355_create_outlook_appointments_based_on_criteria()

Dim i As Long
Const wdPASTERTF As Long = 1

Sheets("Email").Select

On Error GoTo Err_Execute

With CreateObject("Outlook.Application")
With .GetNamespace("MAPI")
With .GetDefaultFolder(olFolderCalendar)
For i = 11 To Cells(Rows.Count, 4).End(xlUp).Row
With .Items.Add(olAppointmentItem)
.MeetingStatus = olMeeting
.Subject = Cells(i, 6)
'.Location = Cells(i, 2)
'.Body = RangetoHTML(Worksheets(Cells(i, 26).Value).UsedRange.SpecialCells(xlCellTypeVisible))
'.Attachments.Add Cells(i, 14).Value
.Categories = Cells(i, 7)
.Start = Cells(i, 13) + Cells(i, 14) '+ TimeValue("9:00:00")
.End = Cells(i, 13) + Cells(i, 15) '+TimeValue("10:00:00")
.BusyStatus = olBusy
'.ReminderMinutesBeforeStart = Cells(i, 12)
.ReminderSet = True
.Recipients.Add(Cells(i, 12).Value).Type = olRequired
Worksheets(Cells(i, 26).Value).UsedRange.SpecialCells(xlCellTypeVisible).Copy
.Display
.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With
Next i
End With
End With
End With

Exit Sub

Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."

End Sub

aravindhan_3
01-31-2017, 08:52 PM
Hi,

thanks & sorry for the delay in response, I am still getting the same error, it stops in .subject saying "An error occurred - Exporting items to Calendar"
it will be a great help if you could test the same from your end so that you can see the error:(

thanks again for your help. R
egards
Arvind

mancubus
01-31-2017, 11:32 PM
comment "On Error...." line (insert a single quote maek biefore letter O), run the code, tell us at which line it throws error.

this code worked for me.

aravindhan_3
02-01-2017, 10:16 AM
Hi,
thanks, it stops at .subject line
Getting Method 'Subject' of object appointmentitem failed

Regard
Arvind

mancubus
02-01-2017, 01:59 PM
Subject property's type is string.

googling didn't help much.

i have read it might be related with authorization issues or missing libraries, or maybe win version.

attached is a working file with Office 2016 32bit on win10 64bit machine.

try it.
if it works adopt the code in your original file to the code in this workbook.
if it does not work, google is your best fried. good luck.