Excel exceeding maximum number of connections to outlook

[samuelimtech]

Hi all,

like most we use Microsoft exchange server for emails and for no reason I keep getting an error message stating I have exceeded the max number of connections.
the code has worked for months IT increase the server size and then deny this has nothing to do with them.

anywho less of the whinging, the code below is part of a loop of about 50 and fails on the highlighted line.
as far as I can see all references to outlook are set to nothing at the end and I thought this would be sufficient to break the connections before the next loop creates them again.

any ideas of where im going wrong??


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
On Error Resume Next
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
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



End Sub

[snb]

If this is part of a loop: it's not obvious to link to outlook every time
Before starting the loop you can establish the link to outlook once and use that link in the loop 50 times or mote.

PS I would reduce the amount of 'variables' that do not vary.
Dit you create this code yourself or did you 'borrow' it ?

[samuelimtech]

No I borrowed it, I found it online and it did exactly what I needed to but I needed to do it 50 times so I made a loop and call it every time.
so I understand you correctly what your essentially saying is put the loop inside the above script instead of the script inside the loop?

that's actually a pretty brill idea thank you, in the pursuit of learning I will give this a go and hopefully I can work it out thanks

[snb]

Yes, basically:


Sub M_snb()
with createobject("outlook.application")

for j=1 to 50

next

end with
End sub



In this structure you don't even have to set an objectvariable to 'Nothing', because you don't use any.