PDA

View Full Version : close MAPI session using VBA



samuelimtech
06-16-2015, 07:06 AM
Hi all,
this could just as easily fall into outlook page but the codes in an excel and as per there's more people in here :)

ok so ive got some code that downloads calendar information from outlook only it fails now becuase ive exceeded the maxmum number of sessions (32).
i thought by setting everything to nothing this would be mitigated against but no.

does anyone know of a way to ensure that the MAPI sessions are closed, or if anyone has another idea for how to get around this then please be my guest and fiddle with the below code.

thanks


Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)

' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------




Set MyBook = Excel.ThisWorkbook

Dim k As Integer
k = 1

'<------------------------------------------------------------------
'Set names of worksheets, tables and mailboxes here!
Set wsTarget = MyBook.Worksheets(Sheet)
strTable = "tblCalendar" & Sheet
strSharedMailboxName = wsTarget.Range("mailbox").Value
'------------------------------------------------------------------>


Sheets(Sheet).Range("A6:G7").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$6:$G$7"), , xlYes).Name = strTable
'this is where you go when it fails
Set rngStart = wsTarget.Range(strTable).Cells(1, 1)


'Clear out previous data
With wsTarget.Range(strTable)
If .Rows.Count > 1 Then .Rows.Delete
End With


' if no end date was specified, then the requestor only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates, if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
EndDate = StartDate
End If


If EndDate < StartDate Then
MsgBox "Those dates seem switched, please check them and try again.", vbInformation
GoTo ExitProc
End If


' If EndDate - StartDate > 28 Then
' ask if the requestor wants so much info
' If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
' GoTo ExitProc
' End If
'End If


' get or create Outlook object and make sure it exists before continuing


Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
GoTo ExitProc
End If


Set olNS = olApp.GetNamespace("MAPI")




' link to shared calendar
Set objRecipient = olNS.CreateRecipient(strSharedMailboxName)


objRecipient.Resolve


Set myCalItems = olNS.GetSharedDefaultFolder(objRecipient, 9).Items '9=olFolderCalendar
k = 2
With myCalItems
On Error GoTo ExitProc
.Sort "[Start]", False
.IncludeRecurrences = True
End With


StringToCheck = "[Start] >= " & Chr(34) & StartDate & " 12:00 AM" & Chr(34) & " AND [End] <= " & _
Chr(34) & EndDate & " 11:59 PM" & Chr(34)


Set ItemstoCheck = myCalItems.Restrict(StringToCheck)


If ItemstoCheck.Count > 0 Then
' we found at least one appt
' check if there are actually any items in the collection, otherwise exit
If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc


For Each MyItem In ItemstoCheck
If MyItem.Class = 26 Then ' 26=olAppointment
' MyItem is the appointment or meeting item we want,
' set obj reference to it
Set ThisAppt = MyItem


With rngStart
.Offset(NextRow, 0).Value = ThisAppt.Subject
.Offset(NextRow, 1).Value = Format(ThisAppt.start, "MM/DD/YYYY")
.Offset(NextRow, 2).Value = Format(ThisAppt.start, "HH:MM AM/PM")
.Offset(NextRow, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
.Offset(NextRow, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
.Offset(NextRow, 5).Value = ThisAppt.Location


If ThisAppt.Categories <> "" Then
.Offset(NextRow, 6).Value = ThisAppt.Categories
Else
.Offset(NextRow, 6).Value = "n/a"
End If
NextRow = wsTarget.Range(strTable).Rows.Count


End With
End If
Next MyItem


Else
MsgBox "There are no appointments or meetings during" & _
"the time you specified. Exiting now.", vbCritical
End If


ExitProc:


Set MyItem = Nothing
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing

Set objRecipient = Nothing