Excel macro to send meeting requests through outlook

[abhay_547]

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.:)

[GTO]

Crosstposted at: http://www.mrexcel.com/forum/showthread.php?t=500849

[Tinbendr]

I think once you define a category, you should have the label color you need. I changed the test category to 'Unfiled' and it shows the colored label.

As far as the range is concerned, this was the only solution I could find (http://www.rondebruin.nl/mail/folder3/mail4.htm).

David

[abhay_547]

Hi All,

Finally I got a code which uses dataobject method to copy the data from excel sheet to Oulook Meeting request body, It works great now but still the only thing which is not working as per my requirement is the data table (present in excel sheet) which doesn't get pasted with it's format. Is there any way to get the formatting to the same ?. Can we use the Rich Text format or Bitmap to paste only the data table ?. Please help..

Attached is my macro workbook for your reference.

Thanks a lot for your help in advance.http://www.vbforums.com/images/smilies/smile.gif

[abhay_547]

Hi All,

Did anyone get the chance to look into the above post. ?

Thanks a lot for your help in advance.http://www.excelforum.com/images/smilies/smile.gif

[abhay_547]

Hi All,

Did anyone get the chance to look into the above post. ?

Thanks a lot for your help in advance.http://www.excelforum.com/images/smilies/smile.gif

[abhay_547]

Hi All,

I have found a code which had resolved my one issue .i.e. my macro now downloads only the files with specific extensions like xls, xlsx, ppt etc. Earlier it use to download all attachments but still I have following issues which are still outstanding.

1) Download the files from multiple subfolders .i.e. select the folder in tree view and use that selection in main macro to download attachments.
3) Download only the latest files.

I have selected the true for checkboxes in the property of treeview1 so that we can select the multiple folders.

I also got the below code to get the selected folders of outlook as selection for downloading the attachments from them. I need help to incorporate this so that we can fix the issue no.1


Private Sub TreeView1_NodeCheck(ByVal Node As MSComctlLib.Node)
Dim n As Node

If Node.Parent Is Nothing Then
Set n = Node.Child
Do Until n Is Nothing
n.Checked = Node.Checked
Set n = n.Next
Loop
End If
End Sub


I am attaching my updated macro file for your reference. please have a look.



Thanks a lot for your help in advance.:)

[Akkadius]

Hey guys I have been working with this script but have been modifying it for a project that we have running right now.

This is what I have right now:

I would like to be able to actually instead of sending this to the default Calendar, send it to a public calendar via:

\\Public Folders\All Public Folders\Phone Tech Scheduling\*ILEC\Fiber\Techname

I've had this working smoothly with a format, I have cross references of multiple workbooks and sheets displaying information everywhere, the last thing I am trying to figure out is how to get this to send to a public calendar.

Thanks, you guys rock.



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 myPath As String

Application.ScreenUpdating = False
myPath = ActiveWorkbook.Path
'myPath = OpenMAPIFolder("\\Public Folders\All Public Folders\Phone Tech Scheduling")

'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 objFolder = OpenMAPIFolder("\\Public Folders\All Public Folders\Phone Tech Scheduling/*ILEC/Fiber/Don")
'Set olAptItem = objFolder.Items.Add
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment

With olAppItem
' set default appointment value
.Start = Now
.End = Now
.Subject = "No subject"
.Location = ""
.Body = ""
.ReminderSet = True
.MeetingStatus = olMeeting

' read appointment values from the worksheet
On Error Resume Next
.Start = Cells(r, 1).Value + Cells(r, 2).Value
.End = Cells(r, 1).Value + Cells(r, 3).Value
.Subject = Cells(r, 4).Value
.Location = Cells(r, 5).Value
.ReminderSet = Cells(r, 8).Value
.Importance = Right(Cells(r, 9).Value, 1)
.RequiredAttendees = Cells(r, 10).Value
.Categories = "UnassignedTechAppointment" ' add this to be able to delete the testappointments
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With

With olApp
Dim Xl As Excel.Application
Dim Ws As Excel.Worksheet
Dim xlRn As Excel.Range

Set Xl = GetObject(, "Excel.Application")
'Set Ws = Xl.Workbooks.Parent.Worksheets(Cells(r, 1).Offset(0, 5).Value)
'Set xlRn = Ws.Range("MailBodyText")


Dim varBody As String
Dim objdata As DataObject
Dim DataObject As Object
Set objdata = New DataObject

'Application.GoTo Reference:=xlRn
Selection.Copy
objdata.GetFromClipboard
'varBody = objdata.GetText

With olAppItem
.Body = varBody '& vbCrLf & vbCrLf
End With
End With

olAppItem.Close olSave
r = r + 1
'Sheets("scheduleapp").Activate
Wend
Set olAppItem = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
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, "UnassignedTechAppointment", vbTextCompare) = 1 Then
OLF.Items(r).Delete
dCount = dCount + 1
End If
End If
Next r
Set olApp = Nothing
Set OLF = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine. I found it somewhere on the internet but do
'not remember where or who the author is. The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, i
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath <> ""
i = InStr(szPath, "\")
If i Then
szDir = Left(szPath, i - 1)
szPath = Mid(szPath, i + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function

[abhay_547]

Hi Akkadius,

Finally I got a code which uses dataobject method to copy the data from excel sheet to Oulook Meeting request body, It works great now but still the only thing which is not working as per my requirement is the data table (present in excel sheet) which doesn't get pasted with it's format. Is there any way to get the formatting to the same ?. Can we use the Rich Text format or Bitmap to paste only the data table ?. Please help..

Please find the my macro file on the link : http://www.4shared.com/file/yUD6dy56...sts_from_.html (http://www.4shared.com/file/yUD6dy56/Sending_Meeting_Requests_from_.html)

Thanks a lot for your help in advance.http://www.mrexcel.com/forum/images/smilies/icon_smile.gif

[abhay_547]

Hi All,

Did anyone get the chance to look at the above post ?.


Thanks a lot for your help in advance.:bow:

[macariosario]

Hi guys!
I'm quite new in using VBA, actually a newbie. I would like to check if someone can help me in placing a Range of Cell Selection in the body of an Appointment to show what i have in excel. ex range: "B10:M60"

Thank you in advance and more power!
\m/