Hello all,
I have been working on a macro to act as a meeting availability planner of sorts. It interfaces with outlook. I got the macro to work in a test document fine, but as soon as I load it into the prod version of the tool (an excel workbook with several functionalities) it fails with a strange error:-2147467259 The operation failed. Google tells me this is some form of automation error, but none of the few listed solutions have solved the issue.
The code in questions below. It seems to be failing at this line of code: strFBInfo = Recipient.FreeBusy(lblFrDate.Caption, 15)
Almost this exact same line is used earlier in the macro and it works fine. I cant figure out why it fails here.
Note: Don't uncomment the errorhandler for -2147467259 as it gets stuck in a loop in its current form
Im completely stuck. Any help would be greatly appreciated!
I have been working on a macro to act as a meeting availability planner of sorts. It interfaces with outlook. I got the macro to work in a test document fine, but as soon as I load it into the prod version of the tool (an excel workbook with several functionalities) it fails with a strange error:-2147467259 The operation failed. Google tells me this is some form of automation error, but none of the few listed solutions have solved the issue.
The code in questions below. It seems to be failing at this line of code: strFBInfo = Recipient.FreeBusy(lblFrDate.Caption, 15)
Almost this exact same line is used earlier in the macro and it works fine. I cant figure out why it fails here.
Note: Don't uncomment the errorhandler for -2147467259 as it gets stuck in a loop in its current form
Code:
Private Sub cmdSearch_Click()
'On Error GoTo ErrorHandler:
Dim Outlook As Object
Dim myNameSpace As Object
Dim intFBArray() As Integer
Dim colFreeTimes As New Collection
Dim strFBInfo As String
Dim intCounter As Integer
Dim intCounter2 As Integer
Dim intFreeBusyAll As Integer
Dim Recipient As Object
Dim dtFreeTime As Date
Dim colVettedTimes As New Collection
Dim dtToFinal As Date
Dim dtFrFinal As Date
Dim strResult As String
Dim blnAddToVetted As Boolean
Dim bln440Error As Boolean
If lstAttendees.ListCount = 0 Then 'check to make sure at least one person attending meeting
Call MsgBox("No attendees loaded", vbOKOnly, "No attendees")
Exit Sub
End If
If chkMonday.Value = False And chkTuesday.Value = False And chkWednesday.Value = False And chkThursday.Value = False And _
chkFriday.Value = False And chkSaturday.Value = False And chkSunday.Value = False Then
Call MsgBox("At least one day of the week must be selected", vbOKOnly, "No days selected")
Exit Sub
End If
'Clear the Results list
If frmResults.lstResults.ListCount <> 0 Then
For intCounter = frmResults.lstResults.ListCount To 1 Step -1
frmResults.lstResults.RemoveItem (intCounter - 1)
Next
End If
'Get free/busy info for first recipient to get array length
Set Outlook = CreateObject("Outlook.Application")
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set Recipient = myNameSpace.CreateRecipient(gstrRecArray(FindEmail(0), 1))
strFBInfo = Recipient.FreeBusy(lblFrDate.Caption, 15)
ReDim intFBArray(lstAttendees.ListCount, Len(strFBInfo))
'Populate Array (Recipient, 0/1 Free/Busy)
For intCounter = 1 To lstAttendees.ListCount
Set Recipient = myNameSpace.CreateRecipient(gstrRecArray(FindEmail(intCounter - 1), 1))
strFBInfo = Recipient.FreeBusy(lblFrDate.Caption, 15)
If bln440Error = False Then
For intCounter2 = 1 To Len(strFBInfo)
intFBArray(intCounter, intCounter2) = Mid(strFBInfo, intCounter2, 1)
Next
End If
Next
'Compare array elements
intFreeBusyAll = 0
For intCounter2 = 1 To Len(strFBInfo)
If intFBArray(1, intCounter2) = 0 Then 'If the first persons slot is open
For intCounter = 1 To lstAttendees.ListCount 'Check all slots
intFreeBusyAll = intFreeBusyAll + intFBArray(intCounter, intCounter2) 'If one person's slot is busy intFreeBusyAll is other than 0
Next
If intFreeBusyAll = 0 Then 'everyone is free in that time slot
colFreeTimes.Add (intCounter2) 'add the index number (place) of the free slot to the collection
End If
intFreeBusyAll = 0 'reset the variable
End If
Next
If colFreeTimes.Count > 0 Then 'There's at least one free common slot
'For all free times
For intCounter = 1 To colFreeTimes.Count
dtFreeTime = DateAdd("n", (colFreeTimes.Item(intCounter) - 1) * 15, lblFrDate.Caption) 'parse the date time in the smallest units (15 minutes)
If dtFreeTime >= CDate(lblFrDate.Caption & " " & lblFrTime.Caption) Then 'If the free time slot is greater than or equal to the start date & time
If dtFreeTime < CDate(lblToDate.Caption & " " & lblToTime.Caption) Then 'If the free time slot is less than then the finish date & time
If CDate(Format(dtFreeTime, "hh:mm ampm")) >= CDate(lblFrTime.Caption) Then 'Free time slot is greater or equal to the start time
If CDate(Format(dtFreeTime, "hh:mm ampm")) < CDate(lblToTime.Caption) Then 'Free time slot is less than end time
blnAddToVetted = True
If frmPlanner.chkLunch = True Then 'exclude lunch and OK were pressed
If CDate(Format(dtFreeTime, "hh:mm ampm")) < CDate(frmLunch.lblFrLunch.Caption) Or _
CDate(Format(dtFreeTime, "hh:mm ampm")) >= CDate(frmLunch.lblToLunch.Caption) Then
blnAddToVetted = True
Else
blnAddToVetted = False
End If
End If
Select Case DatePart("w", dtFreeTime)
Case 1 'Sunday
If chkSunday.Value = False Then
blnAddToVetted = False
End If
Case 2 'Monday
If chkMonday.Value = False Then
blnAddToVetted = False
End If
Case 3 'Tuesday
If chkTuesday.Value = False Then
blnAddToVetted = False
End If
Case 4 'Wednesday
If chkWednesday.Value = False Then
blnAddToVetted = False
End If
Case 5 'Thursday
If chkThursday.Value = False Then
blnAddToVetted = False
End If
Case 6 'Friday
If chkFriday.Value = False Then
blnAddToVetted = False
End If
Case 7 'Saturday
If chkSaturday.Value = False Then
blnAddToVetted = False
End If
End Select
If blnAddToVetted = True Then
colVettedTimes.Add (dtFreeTime)
End If
End If
End If
Else 'If the free time slot is equal to or greater than the end time - stop looking
Exit For
End If
End If
Next
If colVettedTimes.Count > 0 Then
'Combine all consecutive free time slots
For intCounter = 1 To colVettedTimes.Count
dtFrFinal = CDate(colVettedTimes.Item(intCounter))
dtToFinal = CDate(DateAdd("n", 15, colVettedTimes.Item(intCounter)))
Do Until CStr(dtToFinal) <> CStr(colVettedTimes.Item(intCounter + 1))
dtToFinal = CDate(DateAdd("n", 15, dtToFinal))
intCounter = intCounter + 1
If intCounter = colVettedTimes.Count Then 'current counter is now on last entry
Exit Do
End If
Loop
If dtToFinal >= DateAdd("n", spnDuration.Value, dtFrFinal) Then 'only add if difference between consecutive to and from is greater or equal to the minimum duration
strResult = Format(dtFrFinal, "yyyy-mm-dd hh:mm AMPM") & " To " & Format((dtToFinal), "hh:mm AMPM")
frmResults.lstResults.AddItem (strResult) 'add the date time to the list
End If
If intCounter = colVettedTimes.Count Then 'current counter is now the last entry
Exit For
End If
Next
Else
Call MsgBox("No common free times found for that duration.", vbOKOnly, "No results")
End If
Else
Call MsgBox("No common free times found for that duration.", vbOKOnly, "No results")
End If
If frmResults.lstResults.ListCount = 0 Then
Call MsgBox("No common free times found for that duration.", vbOKOnly, "No results")
Else
If frmResults.Visible = False Then
frmResults.Show vbModeless
End If
End If
Set Outlook = Nothing
Set myNameSpace = Nothing
Set Recipient = Nothing
Exit Sub
ErrorHandler:
If Err.Number = 440 Then
bln440Error = True
'ElseIf Err.Number = -2147467259 Then
'Resume
Else
MsgBox Err.Number & " " & Err.Description
End
End If
Resume Next
End SubIm completely stuck. Any help would be greatly appreciated!
