Modify existing VBScript that works in Office 2007 to work in both Office 2007 and 2010

Hello,

We have a vbscript that was created a few years ago (and modified a few times since then - thanks BlueDevilFan).  It works fine in Office 2007, but it has issues in Office 2010.  The script basically collects ‘appointments’ from several calendars located in Exchange public folders (for a specific date), then puts the results in an Excel spreadsheet (and sorts the items by start time).  

It works fine when we run it from a workstation with Office 2007 (running on XP workstations), but when we run it from a workstation with Office 2010  (and Win7 – but I think the issue is with Office 2010, not Win7), it doesn’t ‘restrict’ the items it collects to the date we specify – it appears to collect a week’s worth of appointments…  I’ve done some testing with various appointment/meeting times, lengths, etc., and it seems to have something to do with how the items are ‘restricted’ to the date we specify.  

It doesn’t seem to be an issue with connecting to the public folders, and finding the calendars, because it finds the appropriate meetings, but it finds/provides meetings for the entire week (or at least several days-worth, rather than the one day we specify).  And the same script still works fine in XP…  So I’m thinking it’s an issue with how the items are ‘collected’ or ‘restricted’ to the specific date – some change between Office/Outlook 2007 and 2010.  

We’d like to modify the existing script so that it will work in both Office 2007 and 2010.  

BlueDevilFan was very helpful in the past (and will probably be very familiar with how this works), if he’s available for comments.  For more background, the original question is located here:
https://www.experts-exchange.com/questions/26454432/convert-outlook-vba-to-vbs.html

Below is the existing VBScript (I changed the network locations, room names, and removed some of the additional calendar names).  

Thanks

Const olPublicFoldersAllPublicFolders = 18
On Error Resume Next
Dim olkApp, olkSes, olkFolder, olkItems, olkAppt, excApp, excWkb, excSht, excRng, lngRow, arrTitle, datDate

'Launch Outlook'
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon "Outlook"

'Launch Excel and open the spreadsheet'
Set excApp = CreateObject("Excel.Application")
excApp.Visible = True
'version 2
Set excWkb = excApp.Workbooks.Open("\\somenetworkshare\MeetingsMaster.xltx")
Set excSht = excWkb.Worksheets(1)
    'Range("A2:U4450").SpecialCells(xlCellTypeConstants).ClearContents
    'If bolClearWorksheet Then
    Set excRng = excSht.Range("A1").CurrentRegion
    lngRow = excRng.Rows.count
    'excApp.Rows(2 & ":" & lngRow).Delete
    lngRow = 3

'Set date for schedule
datDate = InputBox("Enter the date you want to create a video schedule for:", "Export Calendars to Excel", Date)
excSht.Cells(1,1) = FormatDateHeader(datDate)

'Connect to and process the shared calendar - One'
Set olkFolder = olkSes.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Conference Rooms").Folders("Conference Room - One")
Set olkItems = olkFolder.Items.Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 0:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")
olkItems.Sort "[Start]"
olkItems.IncludeRecurrences = True
For Each olkAppt In olkItems
    arrTitle = Split(olkAppt.Subject, " - ")
    excSht.Cells(lngRow, 1) = FormatHoursAndMinutes(olkAppt.Start) & "-" & FormatHoursAndMinutes(olkAppt.End)
    excSht.Cells(lngRow, 2) = "One"
    'excSht.Cells(lngRow, 3) = Replace((Trim(arrTitle(0))), "(One)", "", 1, -1, vbTextCompare)
    excSht.Cells(lngRow, 3) = Replace(Replace((Trim(arrTitle(0))), "(One)", "", 1, -1, vbTextCompare), "(TWO)", "", 1, -1, vbTextCompare)
    excSht.Cells(lngRow, 4) = Trim(arrTitle(2))
    excSht.Cells(lngRow, 5) = Trim(arrTitle(3))
    lngRow = lngRow + 1
Next

'Connect to and process the shared calendar - Two'
Set olkFolder = olkSes.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Conference Rooms").Folders("Conference Room-Two")
Set olkItems = olkFolder.Items.Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 0:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")
olkItems.Sort "[Start]"
olkItems.IncludeRecurrences = True
For Each olkAppt In olkItems
    arrTitle = Split(olkAppt.Subject, " - ")
    excSht.Cells(lngRow, 1) = FormatHoursAndMinutes(olkAppt.Start) & "-" & FormatHoursAndMinutes(olkAppt.End)
    excSht.Cells(lngRow, 2) = "Two"
    excSht.Cells(lngRow, 3) = Replace((Trim(arrTitle(0))), "(Two)", "", 1, -1, vbTextCompare)
    'excSht.Cells(lngRow, 3) = Replace(Replace((Trim(arrTitle(0))), "(Exec)", "", vbTextCompare), "(TWO)", "")
    excSht.Cells(lngRow, 4) = Trim(arrTitle(2))
    excSht.Cells(lngRow, 5) = Trim(arrTitle(3))
    lngRow = lngRow + 1
Next

'Connect to and process the shared calendar - Some Office'
Set olkFolder = olkSes.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Conference Rooms").Folders("Some Office")
Set olkItems = olkFolder.Items.Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 0:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")
olkItems.Sort "[Start]"
olkItems.IncludeRecurrences = True
For Each olkAppt In olkItems
    arrTitle = Split(olkAppt.Subject, " - ")
    excSht.Cells(lngRow, 1) = FormatHoursAndMinutes(olkAppt.Start) & "-" & FormatHoursAndMinutes(olkAppt.End)
    excSht.Cells(lngRow, 2) = "Some Office"
    excSht.Cells(lngRow, 3) = Replace((Trim(arrTitle(0))), "(Some Office)", "")
    excSht.Cells(lngRow, 4) = Trim(arrTitle(2))
    excSht.Cells(lngRow, 5) = Trim(arrTitle(3))
    lngRow = lngRow + 1
Next

'excSht.Range("A:E").Sort Key1:=excSht.Range("A:A"), Order1:=1
' works minus header row - excSht.Range("A:E").Sort excSht.Range("A:A"), 1
excSht.Range("A3:G107").Sort excSht.Range("A:A"), 1
' (with 1 header row) excSht.Range("A:E").Sort excSht.Range("A:A"), 1,,,,,,1 

'Save the spreadsheet and exit Excel'
Set excRng = Nothing
Set excSht = Nothing
'excWkb.Save
Set excWkb = Nothing
'excApp.Quit
Set excApp = Nothing

'Clean-up the Outlook objects'
Set olkFolder = Nothing
Set olkItems = Nothing
Set olkAppt = Nothing
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing

'Prompting user to save file
msgbox ("Video Schedule has been created.  Please save the spreadsheet to the following location:    \\somenetworkshare\shared documents\video schedules\VIDEO SCHEDULES\2013  ")

Function OutlookDateFormat(varDate)
    Dim intHour, strAMPM
    intHour = Hour(varDate)
    If intHour > 12 Then
        intHour = intHour - 12
        strAMPM = "PM"
    Else
        strAMPM = "AM"
    End If
    OutlookDateFormat = Month(varDate) & "/" & Day(varDate) & "/" & Year(varDate) & " " & intHour & ":" & Minute(varDate) & " " & strAMPM
End Function

Function StrZero(varNumber, intLength)
    ' Purpose: Pad a number with zeroes to the given length and return it as a string.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim intItemLength
    If IsNumeric(varNumber) Then
        intItemLength = Len(CStr(Int(varNumber)))
        If intItemLength < intLength Then
            StrZero = String(intLength - intItemLength, "0") & varNumber
        Else
            StrZero = varNumber
        End If
    Else
        StrZero = CStr(varNumber)
    End If
End Function

Function FormatHoursAndMinutes(varDate)
    FormatHoursAndMinutes = StrZero(Hour(varDate),2) & StrZero(Minute(varDate),2)
End Function

Function FormatDateHeader(datValue)
    FormatDateHeader = WeekdayName(Weekday(datValue)) & vbLf & StrZero(Day(datValue), 2) & UCase(MonthName(Month(datValue), True)) & Year(datValue)
End Function

Select allOpen in new window