We have an excel macro stored on a shared drive. If we open and run it on computer A works like a charm. but if we try to open it on computer B or C it runs partway through and then errors out
we have check all the security settings and all computers have same os XP same office 2007
Even tried it from a windows 7 with office 2010 same issue
this is the message we get
Run-time error '-2147467259 (80004005)'; the operation failed
If I click the debug it always goes to this line
NumAppt = fldOutlookAppts.Items.Count
Here is the macro
Dim objOutlookApp As New Outlook.Application
Dim objOutlookNS As Outlook.NameSpace
Dim fldOutlookAppts As Outlook.MAPIFolder
Dim objOtherUser As Outlook.Recipient
Dim objOutlookItems As Outlook.Items
Private Type tCalendarFolders
Folder As Outlook.MAPIFolder
Name As String
ID As String
Index As Long
End Type
Private Type tApptOrder
lIndex As Long
dStartTime As Date
dEndTime As Date
objAppt As Object
End Type
Dim aryApptOrder() As tApptOrder
Private Sub btnClear_Click()
'xlWB.ActiveSheet.Cells.Clear
End Sub
Private Sub btnSelectAll_Click()
i = 1
Do While i < lvwRooms.ListItems.Count + 1
If lvwRooms.ListItems(i).Checked = False Then
lvwRooms.ListItems(i).Checked = True
End If
i = i + 1
Loop
End Sub
Private Sub btnUnSelectAll_Click()
i = 1
Do While i < lvwRooms.ListItems.Count + 1
If lvwRooms.ListItems(i).Checked = True Then
lvwRooms.ListItems(i).Checked = False
End If
i = i + 1
Loop
End Sub
Private Sub CommandButton1_Click()
Set objOutlookNS = objOutlookApp.GetNamespace("MAPI")
Dim TestIt As Object
Dim MyRange As Object
Dim strRangeQuery As String
Dim strRangeQ As String
Dim Counter As Integer
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim RoomNum As Integer
Dim NumAppt As Integer
Dim lCounter As Integer
Dim strTodayStart As String
Dim strTodayEnd As String
Dim i As Integer
ReDim aryApptOrder(0)
Counter = 1
RoomNum = 1
2008 Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add ' create a new workbook
Do While Counter < lvwRooms.ListItems.Count + 1
If lvwRooms.ListItems(Counter).Checked Then
Set objOtherUser = objOutlookNS.CreateRecipient(lvwRooms.ListItems(Counter).Text)
Set fldOutlookAppts = objOutlookNS.GetSharedDefaultFolder(objOtherUser, olFolderCalendar)
fldOutlookAppts.Items.IncludeRecurrences = True
NumAppt = fldOutlookAppts.Items.Count
Set objOutlookItems = fldOutlookAppts.Items
objOutlookItems.IncludeRecurrences = True
Set objOutlookItems = fldOutlookAppts.Items
lCounter = 0
strTodayStart = txtStart.Value & " 00:00"
strTodayEnd = txtEnd.Value & " 23:59"
strRangeQuery = "[End] > """ & strTodayStart & """ and [Start] <= """ & strTodayEnd & """"
strRangeQ = strTodayStart
objOutlookItems.Sort "[Start]", False
objOutlookItems.IncludeRecurrences = True
Set MyRange = objOutlookItems
Set TestIt = MyRange.Find(strRangeQuery)
While TypeName(TestIt) <> "Nothing"
ReDim Preserve aryApptOrder(lCounter)
aryApptOrder(lCounter).lIndex = lCounter + 1
aryApptOrder(lCounter).dStartTime = CDate(TestIt.Start)
aryApptOrder(lCounter).dEndTime = CDate(TestIt.End)
Set aryApptOrder(lCounter).objAppt = TestIt
lCounter = lCounter + 1
Set TestIt = MyRange.FindNext
Wend
i = 0
With xlWB.ActiveSheet
If RoomNum = 1 Then
.Cells(RoomNum, 1).Formula = "ROOM LISTING AND DESCRIPTIONS"
.Cells(RoomNum, 1).Font.Bold = True
.Cells(RoomNum, 1).Font.Italic = True
'.Cells(RoomNum, 1).Font.Color = RGB(0, 255, 0)
.Cells(RoomNum, 1).Font.Size = 14
RoomNum = RoomNum + 2
End If
If lCounter > 0 Then
RoomNum = RoomNum + 1
.Cells(RoomNum, 1).Formula = lvwRooms.ListItems(Counter).Key
.Cells(RoomNum, 1).Font.Bold = True
'.Cells(RoomNum, 1).Font.Color = RGB(0, 0, 255)
.Cells(RoomNum, 1).Font.Size = 12
End If
End With
Do While lCounter > i
With xlWB.ActiveSheet
.Cells(RoomNum + 1, 2).Formula = aryApptOrder(lCounter - 1).dStartTime
.Cells(RoomNum + 1, 3).Formula = aryApptOrder(lCounter - 1).dEndTime
.Cells(RoomNum + 1, 4).Formula = aryApptOrder(lCounter - 1).objAppt
End With
RoomNum = RoomNum + 1
lCounter = lCounter - 1
Loop
End If
'If lCounter > 0 Then
' RoomNum = RoomNum + 3
'End If
Counter = Counter + 1
Loop
'xlWB.Close False ' close the workbook without saving
'xlApp.Quit ' close the Excel application
'Set xlWB = Nothing
'Set xlApp = Nothing
'If Dir("C:\Foldername\MyNewExcelWB.xls") <> "" Then
' Kill "C:\Foldername\MyNewExcelWB.xls"
'End If
'.SaveAs ("Z:\Foldername\MyNewExcelWB.xls")
End Sub
Private Sub UserForm_Activate()
lvwRooms.ListItems.Clear
lvwRooms.ColumnHeaders.Clear
lvwRooms.ColumnHeaders.Add , , "Room Name"
lvwRooms.ColumnHeaders(1).Width = 1500
With lvwRooms
.ListItems.Add 1, "RL103A - Multipurpose(was Dining Room A/B)", "RDH - Private Dining A"
.ListItems.Add 2, "RL103B - Multipurpose(was Dining Room A/B)", "RDH - Private Dining B"
.ListItems.Add 3, "SCL401 - Dana Soltes Auditorium", "RDHSC - L401 (150)"
.ListItems.Add 4, "SCL501 - Multipurpose/Classroom/Telehealth", "RDHSC - L501 (14)"
.ListItems.Add 5, "SCL502 - Multipurpose/Classroom", "RDHSC - L502 (14)"
.ListItems.Add 6, "SCL503 - Multipurpose/Classroom", "RDHSC - L503 (14)"
.ListItems.Add 7, "SCL504 - Multipurpose/Classroom/Telehealth", "RDHSC - L504 (14)"
.ListItems.Add 8, "SC2201 - Multipurpose", "RDHSC - 2201 (4)"
.ListItems.Add 9, "SC2203 - Computer Training Stations/Telehealth", "RDHSC - 2203 (15 Computer lab)"
.ListItems.Add 10, "SC2206 - Computer Training Stations", "RDHSC - 2206 (12 Computer lab)"
.ListItems.Add 11, "SC3201 - Multipurpose", "RDHSC - 3201 (10)"
.ListItems.Add 12, "SC3202 - Multipurpose", "RDHSC - 3202 (18)"
.ListItems.Add 13, "SC3203 - Multipurpose", "RDHSC - 3203 (8)"
.ListItems.Add 14, "SC3204 - Multipurpose/Telehealth", "RDHSC - 3204 (16)"
.ListItems.Add 15, "SC3205 - Multipurpose", "RDHSC - 3205 (8)"
.ListItems.Add 16, "SC3207 - Media Room", "RDHSC - 3207 (12)"
.ListItems.Add 17, "SC3208 - Boardroom", "RDHSC - 3208 (25)"
.ListItems.Add 18, "5010-1009 - Multipurpose(was Meeting Room #1)", "5010 - Meeting Room # 1"
.ListItems.Add 19, "RDH - RM 911", "RDH - RM 911"
.ListItems.Add 20, "CACC - WCM 1008", "CACC - WCM 1008"
End With
End Sub
Can anyone point me in the right direction?
we have check all the security settings and all computers have same os XP same office 2007
Even tried it from a windows 7 with office 2010 same issue
this is the message we get
Run-time error '-2147467259 (80004005)'; the operation failed
If I click the debug it always goes to this line
NumAppt = fldOutlookAppts.Items.Count
Here is the macro
Dim objOutlookApp As New Outlook.Application
Dim objOutlookNS As Outlook.NameSpace
Dim fldOutlookAppts As Outlook.MAPIFolder
Dim objOtherUser As Outlook.Recipient
Dim objOutlookItems As Outlook.Items
Private Type tCalendarFolders
Folder As Outlook.MAPIFolder
Name As String
ID As String
Index As Long
End Type
Private Type tApptOrder
lIndex As Long
dStartTime As Date
dEndTime As Date
objAppt As Object
End Type
Dim aryApptOrder() As tApptOrder
Private Sub btnClear_Click()
'xlWB.ActiveSheet.Cells.Clear
End Sub
Private Sub btnSelectAll_Click()
i = 1
Do While i < lvwRooms.ListItems.Count + 1
If lvwRooms.ListItems(i).Checked = False Then
lvwRooms.ListItems(i).Checked = True
End If
i = i + 1
Loop
End Sub
Private Sub btnUnSelectAll_Click()
i = 1
Do While i < lvwRooms.ListItems.Count + 1
If lvwRooms.ListItems(i).Checked = True Then
lvwRooms.ListItems(i).Checked = False
End If
i = i + 1
Loop
End Sub
Private Sub CommandButton1_Click()
Set objOutlookNS = objOutlookApp.GetNamespace("MAPI")
Dim TestIt As Object
Dim MyRange As Object
Dim strRangeQuery As String
Dim strRangeQ As String
Dim Counter As Integer
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim RoomNum As Integer
Dim NumAppt As Integer
Dim lCounter As Integer
Dim strTodayStart As String
Dim strTodayEnd As String
Dim i As Integer
ReDim aryApptOrder(0)
Counter = 1
RoomNum = 1
2008 Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add ' create a new workbook
Do While Counter < lvwRooms.ListItems.Count + 1
If lvwRooms.ListItems(Counter).Checked Then
Set objOtherUser = objOutlookNS.CreateRecipient(lvwRooms.ListItems(Counter).Text)
Set fldOutlookAppts = objOutlookNS.GetSharedDefaultFolder(objOtherUser, olFolderCalendar)
fldOutlookAppts.Items.IncludeRecurrences = True
NumAppt = fldOutlookAppts.Items.Count
Set objOutlookItems = fldOutlookAppts.Items
objOutlookItems.IncludeRecurrences = True
Set objOutlookItems = fldOutlookAppts.Items
lCounter = 0
strTodayStart = txtStart.Value & " 00:00"
strTodayEnd = txtEnd.Value & " 23:59"
strRangeQuery = "[End] > """ & strTodayStart & """ and [Start] <= """ & strTodayEnd & """"
strRangeQ = strTodayStart
objOutlookItems.Sort "[Start]", False
objOutlookItems.IncludeRecurrences = True
Set MyRange = objOutlookItems
Set TestIt = MyRange.Find(strRangeQuery)
While TypeName(TestIt) <> "Nothing"
ReDim Preserve aryApptOrder(lCounter)
aryApptOrder(lCounter).lIndex = lCounter + 1
aryApptOrder(lCounter).dStartTime = CDate(TestIt.Start)
aryApptOrder(lCounter).dEndTime = CDate(TestIt.End)
Set aryApptOrder(lCounter).objAppt = TestIt
lCounter = lCounter + 1
Set TestIt = MyRange.FindNext
Wend
i = 0
With xlWB.ActiveSheet
If RoomNum = 1 Then
.Cells(RoomNum, 1).Formula = "ROOM LISTING AND DESCRIPTIONS"
.Cells(RoomNum, 1).Font.Bold = True
.Cells(RoomNum, 1).Font.Italic = True
'.Cells(RoomNum, 1).Font.Color = RGB(0, 255, 0)
.Cells(RoomNum, 1).Font.Size = 14
RoomNum = RoomNum + 2
End If
If lCounter > 0 Then
RoomNum = RoomNum + 1
.Cells(RoomNum, 1).Formula = lvwRooms.ListItems(Counter).Key
.Cells(RoomNum, 1).Font.Bold = True
'.Cells(RoomNum, 1).Font.Color = RGB(0, 0, 255)
.Cells(RoomNum, 1).Font.Size = 12
End If
End With
Do While lCounter > i
With xlWB.ActiveSheet
.Cells(RoomNum + 1, 2).Formula = aryApptOrder(lCounter - 1).dStartTime
.Cells(RoomNum + 1, 3).Formula = aryApptOrder(lCounter - 1).dEndTime
.Cells(RoomNum + 1, 4).Formula = aryApptOrder(lCounter - 1).objAppt
End With
RoomNum = RoomNum + 1
lCounter = lCounter - 1
Loop
End If
'If lCounter > 0 Then
' RoomNum = RoomNum + 3
'End If
Counter = Counter + 1
Loop
'xlWB.Close False ' close the workbook without saving
'xlApp.Quit ' close the Excel application
'Set xlWB = Nothing
'Set xlApp = Nothing
'If Dir("C:\Foldername\MyNewExcelWB.xls") <> "" Then
' Kill "C:\Foldername\MyNewExcelWB.xls"
'End If
'.SaveAs ("Z:\Foldername\MyNewExcelWB.xls")
End Sub
Private Sub UserForm_Activate()
lvwRooms.ListItems.Clear
lvwRooms.ColumnHeaders.Clear
lvwRooms.ColumnHeaders.Add , , "Room Name"
lvwRooms.ColumnHeaders(1).Width = 1500
With lvwRooms
.ListItems.Add 1, "RL103A - Multipurpose(was Dining Room A/B)", "RDH - Private Dining A"
.ListItems.Add 2, "RL103B - Multipurpose(was Dining Room A/B)", "RDH - Private Dining B"
.ListItems.Add 3, "SCL401 - Dana Soltes Auditorium", "RDHSC - L401 (150)"
.ListItems.Add 4, "SCL501 - Multipurpose/Classroom/Telehealth", "RDHSC - L501 (14)"
.ListItems.Add 5, "SCL502 - Multipurpose/Classroom", "RDHSC - L502 (14)"
.ListItems.Add 6, "SCL503 - Multipurpose/Classroom", "RDHSC - L503 (14)"
.ListItems.Add 7, "SCL504 - Multipurpose/Classroom/Telehealth", "RDHSC - L504 (14)"
.ListItems.Add 8, "SC2201 - Multipurpose", "RDHSC - 2201 (4)"
.ListItems.Add 9, "SC2203 - Computer Training Stations/Telehealth", "RDHSC - 2203 (15 Computer lab)"
.ListItems.Add 10, "SC2206 - Computer Training Stations", "RDHSC - 2206 (12 Computer lab)"
.ListItems.Add 11, "SC3201 - Multipurpose", "RDHSC - 3201 (10)"
.ListItems.Add 12, "SC3202 - Multipurpose", "RDHSC - 3202 (18)"
.ListItems.Add 13, "SC3203 - Multipurpose", "RDHSC - 3203 (8)"
.ListItems.Add 14, "SC3204 - Multipurpose/Telehealth", "RDHSC - 3204 (16)"
.ListItems.Add 15, "SC3205 - Multipurpose", "RDHSC - 3205 (8)"
.ListItems.Add 16, "SC3207 - Media Room", "RDHSC - 3207 (12)"
.ListItems.Add 17, "SC3208 - Boardroom", "RDHSC - 3208 (25)"
.ListItems.Add 18, "5010-1009 - Multipurpose(was Meeting Room #1)", "5010 - Meeting Room # 1"
.ListItems.Add 19, "RDH - RM 911", "RDH - RM 911"
.ListItems.Add 20, "CACC - WCM 1008", "CACC - WCM 1008"
End With
End Sub
Can anyone point me in the right direction?
