abhay_547
10-11-2010, 08:44 AM
Hi All,
I have got the below macro which loops through the rows in a sheet and schedules appointments in outlook in as per my requirement but I have following issues with the below macro.
1) I want to know how I can also add the Label along with the .Body, Subject, Location etc.. Label is usually used to define colours for appointments for e.g. Important, Business, Personal etc.
2) I want to know how I can insert / copy a long text with some URL/links in it and a data table on my appointment body. I have all data in a excel sheet in a name range. .i.e. "Mailbodytext". This range is quit big .i.e. from Cell A1:X55. It's properly formatted. I want to copy this range along with formatting without gridlines on my appointment body.
Option Explicit
' requires a reference to the Microsoft Outlook x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
'Dim myrange As String
'myrange = Range("myrange").Value
DeleteTestAppointments ' 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 appointment data in the active worksheet
While Len(Cells(r, 1).Formula) > 0
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
.Start = Now
.End = Now
.Subject = "No subject"
.Location = ""
.Body = ""
.ReminderSet = True
.BusyStatus = olFree
.RequiredAttendees = ""
' read appointment values from the worksheet
On Error Resume Next
.Start = Cells(r, 1).Value + Cells(r, 2).Value
.End = Cells(r, 8).Value + Cells(r, 3).Value
.Subject = Cells(r, 4).Value
.Location = Cells(r, 5).Value
.Body = varBody
.ReminderSet = Cells(r, 7).Value
.BusyStatus = Cells(r, 9).Value
.RequiredAttendees = Cells(r, 10).Value
.Categories = "TestAppointment" ' add this to be able to delete the testappointments
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
End Sub
Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = GetObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Set OLF = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
dCount = 0
For r = OLF.Items.Count To 1 Step -1
If TypeName(OLF.Items(r)) = "AppointmentItem" Then
If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
OLF.Items(r).Delete
dCount = dCount + 1
End If
End If
Next r
Set olApp = Nothing
Set OLF = Nothing
End Sub
I have attached my macro file for your reference.
Thanks a lot for your help in advance.:)
I have got the below macro which loops through the rows in a sheet and schedules appointments in outlook in as per my requirement but I have following issues with the below macro.
1) I want to know how I can also add the Label along with the .Body, Subject, Location etc.. Label is usually used to define colours for appointments for e.g. Important, Business, Personal etc.
2) I want to know how I can insert / copy a long text with some URL/links in it and a data table on my appointment body. I have all data in a excel sheet in a name range. .i.e. "Mailbodytext". This range is quit big .i.e. from Cell A1:X55. It's properly formatted. I want to copy this range along with formatting without gridlines on my appointment body.
Option Explicit
' requires a reference to the Microsoft Outlook x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
'Dim myrange As String
'myrange = Range("myrange").Value
DeleteTestAppointments ' 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 appointment data in the active worksheet
While Len(Cells(r, 1).Formula) > 0
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
.Start = Now
.End = Now
.Subject = "No subject"
.Location = ""
.Body = ""
.ReminderSet = True
.BusyStatus = olFree
.RequiredAttendees = ""
' read appointment values from the worksheet
On Error Resume Next
.Start = Cells(r, 1).Value + Cells(r, 2).Value
.End = Cells(r, 8).Value + Cells(r, 3).Value
.Subject = Cells(r, 4).Value
.Location = Cells(r, 5).Value
.Body = varBody
.ReminderSet = Cells(r, 7).Value
.BusyStatus = Cells(r, 9).Value
.RequiredAttendees = Cells(r, 10).Value
.Categories = "TestAppointment" ' add this to be able to delete the testappointments
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
End Sub
Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = GetObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Set OLF = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
dCount = 0
For r = OLF.Items.Count To 1 Step -1
If TypeName(OLF.Items(r)) = "AppointmentItem" Then
If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
OLF.Items(r).Delete
dCount = dCount + 1
End If
End If
Next r
Set olApp = Nothing
Set OLF = Nothing
End Sub
I have attached my macro file for your reference.
Thanks a lot for your help in advance.:)