Solved

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

Posted on 2014-01-17
37
568 Views
Last Modified: 2014-02-25
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:
http://www.experts-exchange.com/Microsoft/Development/MS_Access/Q_26454432.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

Open in new window

0
Comment
Question by:damoncf1234
  • 18
  • 10
  • 7
37 Comments
 
LVL 14

Assisted Solution

by:Zack Barresse
Zack Barresse earned 250 total points
ID: 39790404
Hi there,

The Restrict method looks normal. I would have the Sort run first though, then check the date range. I don't think it's supposed to matter, but every Outlook guru I know does it that way, so that's how I've always done it. So the logic would be 1) set your items, 2) sort your items, 3) include recurrences or not, 4) restrict, 5) iterate restricted items. Not sure if it would make much difference or not.

You could shorten it up a bit as well. Granted it'd be easier with a Format() function (for your dates/times), but I don't think you need the additional function calls. This is LIGHTLY tested. It adds a bit more functionality, like grabbing an open instance of an app if it's already open, and using the file if it's already open, some minor error handling, etc.

RunTest

Sub RunTest()

    Const xlFileName = "Book2.xlsx"
    Const xlFilePath = "C:\Users\Zack\Desktop\"
    Const olPublicFoldersAllPublicFolders = 18

    Dim olkApp, olkSes, olkFolder, olkItems, olkAppt, excApp, excWkb, excSht, excRng, lngRow, arrTitle, datDate
    Dim olkItem, sFilter, iStep, sNewText, datTemp, sErrorMsg, sPrompt
    Dim datStart, datEnd, bOlOpen, bXlOpen, bCancelled, bError, bWbOpen
    Dim aFolders1(), aFolders2(), aFolders3()

    'Set date for schedule
    bCancelled = True
    bCancelled = False
    bError = False

    'Launch Outlook'
    On Error Resume Next
    Set olkApp = GetObject(, "Outlook.Application")
    bOlOpen = True
    If olkApp Is Nothing Then
        Set olkApp = CreateObject("Outlook.Application")
        bOlOpen = False
    End If
    If olkApp Is Nothing Then
        MsgBox "Outlook not found"
        Exit Sub
    End If
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon "Outlook"

    'Launch Excel and open the spreadsheet'
    Set excApp = GetObject(, "Excel.Application")
    bXlOpen = True
    If excApp Is Nothing Then
        Set excApp = CreateObject("Excel.Application")
        bXlOpen = False
    End If
    If excApp Is Nothing Then
        MsgBox "Excel not found"
        Exit Sub
    End If
    excApp.Visible = True
    'version 2

    datDate = InputBox("Enter the date you want to create a video schedule for:", "Export Calendars to Excel", Date)
    If Len(datDate) = 0 Then
        MsgBox "Action cancelled"
        Exit Sub
    End If

    bWbOpen = CBool(Len(excApp.Workbooks(xlFileName).Name <> 0))
    If bWbOpen = True Then
        Set excWkb = excApp.Workbooks(xlFileName)
    Else
        Set excWkb = excApp.Workbooks.Open(xlFilePath & xlFileName)
    End If
    If excWkb Is Nothing Then
        MsgBox "File not found"
        Exit Sub
    End If

    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
    sFilter = "[Start] >= " & Chr(34) & datDate & Chr(34) & " AND [Start] < " & Chr(34) & datTemp & Chr(34)
    datTemp = WeekdayName(Weekday(datDate), False)
    If Len(DatePart("d", datDate)) = 1 Then datTemp = datTemp & "0"
    datTemp = datTemp & DatePart("d", datDate)
    datTemp = datTemp & UCase(MonthName(DatePart("m", datDate), True)) & DatePart("yyyy", datDate)
    excSht.cells(1, 1) = datTemp
    datTemp = vbNullString: datTemp = CDate(datDate) + 1

    On Error Resume Next
    aFolders1(1) = "Conference Room - One"
    aFolders2(1) = "(One)"
    aFolders3(1) = "(TWO)"
    aFolders1(2) = "Conference Room-Two"
    aFolders2(2) = "(Two)"
    aFolders3(2) = ""
    aFolders1(3) = "Some Office"
    aFolders2(3) = "(Some Office)"
    aFolders3(3) = ""
    For iStep = LBound(aFolders1) To UBound(aFolders1)
        'Connect to and process the shared calendar - One'
        Set olkFolder = olkSes.GetDefaultFolder(9)    ' /// FOR TESTING ONLY ///
        '    Set olkFolder = olkSes.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Conference Rooms").Folders(aFolders1(iStep))
        olkFolder.Items.Sort "[Start]", False
        olkFolder.Items.IncludeRecurrences = True
        Set olkItems = olkFolder.Items.Restrict(sFilter)
        For iCol = 1 To olkItems.Count
            'Dates
            datStart = CStr(CDate(CLng(olkItems.Item(iCol).Start))): datStart = datStart & " " & DatePart("h", olkItems.Item(iCol).Start)
            If DatePart("n", olkItems.Item(iCol).Start) < 10 Then datStart = datStart & "0" & DatePart("n", olkItems.Item(iCol).Start) Else datStart = datStart & DatePart("n", olkItems.Item(iCol).Start)
            datEnd = CStr(CDate(CLng(olkItems.Item(iCol).End))): datEnd = datEnd & " " & DatePart("h", olkItems.Item(iCol).End)
            If DatePart("n", olkItems.Item(iCol).End) < 10 Then datEnd = datEnd & "0" & DatePart("n", olkItems.Item(iCol).End) Else datEnd = datEnd & DatePart("n", olkItems.Item(iCol).End)
            'Subject
            arrTitle = Split(olkAppt.Subject, " - ")
            excSht.cells(lngRow, 1) = Right(datStart, Len(datStart) - InStrRev(datStart, " ")) & "-" & Right(datEnd, Len(datEnd) - InStrRev(datEnd, " "))
            excSht.cells(lngRow, 2) = Replace(Replace(aFolders2(iStep), "(", ""), ")", "")
            'excSht.Cells(lngRow, 3) = Replace((Trim(arrTitle(0))), "(One)", "", 1, -1, vbTextCompare)
            '            excSht.cells(lngRow, 3) = Replace(Replace((Trim(arrTitle(0))), aFolders2(iStep), "", 1, -1, vbTextCompare), "(TWO)", "", 1, -1, vbTextCompare)
            sNewText = Replace((Trim(arrTitle(0))), aFolders2(iStep), "", 1, -1, vbTextCompare)
            If aFolders3(iStep) <> vbNullString Then
                sNewText = Replace(sNewText, aFolders3(iStep), "", 1, -1, vbTextCompare)
            End If
            excSht.cells(lngRow, 3) = sNewText
            If UBound(arrTitle) >= 2 Then excSht.cells(lngRow, 4) = Trim(arrTitle(2))
            If UBound(arrTitle) >= 3 Then excSht.cells(lngRow, 5) = Trim(arrTitle(3))
            lngRow = lngRow + 1
        Next
        Set olkItem = Nothing
        Set olkItems = Nothing
        Set olkFolder = Nothing
    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:G" & lngRow - 1).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
    If bWbOpen = False And bCancelled = False Then
        If bXlOpen = True Then
            excWkb.Save
            excWkb.Close
        End If
    End If
    'excWkb.Save
    Set excWkb = Nothing
    'excApp.Quit
    Set excApp = Nothing

    'Clean-up the Outlook objects'
    Set olkAppt = Nothing
    If Not bCancelled Then olkSes.Logoff
    If bOlOpen = False And bCancelled = False Then
        olkApp.Quit
    End If
    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  ")

End Sub

Open in new window


Try it out and let us know how it goes. I'll test when I can.

HTH

Regards,
Zack Barresse
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39795714
Hi, damoncf1234.

Apologies for taking so long to post to your question.

This post is NOT FOR POINTS.  I'm only commenting because I had promised to take a look at the question prior to Zack's post.

Zack (@firefytr) is correct that my original code is implementing the Restrict backwards.  As he points out, the sequence should be

1.  Get the folder's Items object.
2.  Sort the items
3.  Set IncludeRecurrences to True
4.  Restrict the items with your filter
5.  Read the filtered items

For example

Set olkItems = olkFolder.Items
olkItems.Sort "[Start]"
olkItems.IncludeRecurrences = True
Set olkFiltered = olkItems.Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 0:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")

Open in new window


I don't know why I have them out of order in the original code.  That might account for the problem you're having.  My recommendation is to try Zack's code.  If it fixes the problem, then you should go with it.  If it doesn't , then I'll need to run some tests to see if I can duplicate the problem.
0
 

Author Comment

by:damoncf1234
ID: 39795756
Zack & BlueDevilFan,

Thank you both for your responses.  I'll try your suggestion (having the sort run first) from work tomorrow or Wednesday (the script is on a network I can't access from home).  I'll post back with results.  Hopefully it resolves the issue.  
Thanks again for the responses.  
-Chris
0
 

Author Comment

by:damoncf1234
ID: 39800879
Zack / BlueDevilFan,

Thanks for the response…  I tried your new script (updated the file name/location, conference room names, prefixes, etc.), and it opened Excel, but didn’t do anything beyond that (and showed the popup that the schedule had been created).  

I tried your other suggestion of moving things around in our existing script – sort, recurrences, restrict.  That seems to have helped with the (never-ending results that we were getting with Office 2010).  Now, we get the same results whether it’s run on a machine with Office 2007 or 2010 – but for some reason, we’re getting a few ‘extra’ meetings – that aren’t from the date selected.  

For example, I ran it today, and in one room, there are 10 meetings, but the updated script will show 14 meetings (one from the 23rd, one from the 28th, one from the 29th, and one from the 30th), in addition to the 10 meetings actually occurring today.  

Just for kicks, I tried modifying the ‘restrict’ line to narrow-down the start date/time to just a few hours today, and it seems to ignore the start time.  

I did a few searches today, and found the following items that might explain what’s happening with the restrict method:
http://www.outlookcode.com/codedetail.aspx?id=1206
http://support.microsoft.com/default.aspx?scid=kb;EN-US;292451

Is there an issue with the way the restrict method is used?

Do you know of any reasons why the script would 'include' a few meetings 'from the future' / outside of the specified date within the results?
 
Set olkItems = olkFolder.Items.Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 0:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")

Open in new window


Thanks,
Chris
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 39800895
Hello Chris,

Perhaps it is an improper filter being applied. You only have [Start] defined. So you're restricting the items to where the start date is in the specified range. Should you in fact be filtering for the [End] as well?

Zack
0
 
LVL 76

Accepted Solution

by:
David Lee earned 250 total points
ID: 39801058
Chris,

I adjusted the code and tested it on my computer which is running Office 2010.  It worked perfectly.  Please give this version a try and let us know what happens.

'--> Create some constants
	Const SCRIPT_NAME = "Export Calendars to Excel"
	Const olPublicFoldersAllPublicFolders = 18

'--> Create some variables
	Dim olkApp, olkSes, olkFolder, olkItems, olkHits, olkAppt, excApp, excWkb, excSht, excRng, lngRow, arrTitle, datDate

'--> Turn error handling off
	On Error Resume Next

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

'--> 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:", SCRIPT_NAME, 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
	With olkItems
		.Sort "[Start]"
		.IncludeRecurrences = True
		Set olkHits = .Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 00:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")		
	End With
	For Each olkAppt In olkHits
	    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
	With olkItems
		.Sort "[Start]"
		.IncludeRecurrences = True
		Set olkHits = .Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 00:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")
	End with
	For Each olkAppt In olkHits
	    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
	With olkItems
		.Sort "[Start]"
		.IncludeRecurrences = True
		Set olkHits = .Restrict("[Start] >= '" & OutlookDateFormat(datDate & " 00:01am") & "' AND [Start] < '" & OutlookDateFormat(datDate & " 11:59pm") & "'")
	End with
	For Each olkAppt In olkHits
	    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  ",vbInformation+vbOKOnly, SCRIPT_NAME

'--> That's all folks
	WScript.Quit

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

Open in new window

0
 

Author Comment

by:damoncf1234
ID: 39801099
Zack,

Thanks for the reply.   Possibly...  The existing script that worked with Office 2007 worked with just the Start field applied.  

I just added the [End] times, and it didn't make a difference (still 14 meetings appeared for today, when there are only 10 scheduled).  

I just took off the .Restrict from olkFolder.Items.Restrict(strDayFilter)
So it's now just olkFolder.Items, and it pulls up all future meetings in that room (doesn't restrict to today)...  

I put the .Restrict back on there, and it seems to restrict the results to today (but for some reason it adds those 'extra' four entries - which are from 28/29/30January, for some reason).  It seems like it's 'working', but a few random entries get included from different dates.  

Do you have an idea why it'd be adding these additional entries?  

Thanks,
Chris
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 39801171
Chris,

I'm honestly not sure why it'd be adding the additional dates. I can't see anything on the Restrict method which would be getting those values. You should try BlueDevilFan's latest suggestion and let us know if it works for you as well. If that does work I'd still recommend implementing some of the changes I made, which makes the code more robust.

Zack
0
 

Author Comment

by:damoncf1234
ID: 39801214
Oh, wow...  I didn't even notice that BlueDevilFan posted that new script. I'll test it right now.  Thank you!
0
 

Author Comment

by:damoncf1234
ID: 39801394
BlueDevilFan/Zack,

I just tried the version that BlueDevilFan posted at 3:30pm, and it worked great, and didn't pull up any 'extra' meetings!  

Great!  I compared this script to the original one, and it seems like
set olkItems = olkFolder.Items.Restrict(start date info)
was changed to
With olkItems
    .Sort "[Start]"
    .IncludeRecurrences = True
    Set OlkHite = .Restrict(start date info)

I just updated the original version of the script with those changes from your updated script, and it works great!  Thank you.  (The version running on our (closed) network has some other parts to it - it also changes background and text color based on meeting subjects and keywords, and some other items).  

I just ran it from Office 2007 and 2010 (XP and Win7), and it works great (with no extra meetings!).  

One item that came up was 'Object reference not set to an instance of an object' - when running it from an XP machine with Outlook 2007 closed (not really worried about it, but do you have an idea how to make that go away?).

Thank both of you again,

Chris

(How do you want to split the points up?)
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 39801480
You don't have to give me any points, Chris, they've never been my focus here. :)

For the Outlook 2007 error, is the machine up to date with all Windows and Office service packs? I'd suspect the Windows XP, and make sure it has the latest updates installed. Also, I'm assuming no add-ins are involved. Are you saying you receive that error yet it continues to run, and do so successfully?

Zack
0
 

Author Comment

by:damoncf1234
ID: 39801510
Zack,

Are you sure about the points?  You jumped in pretty quickly and offered some help...  

The XP machine I was testing on probably doesn't have the latest updates (it's on a closed network on blades that no one manages).  I'll try it on a 'regular XP workstation tomorrow'.  We're migrating from XP to Win7 soon, and that was one machine that I could VNC into from here.  

Yes, I'd get that error message on XP, but it would still open the spreadsheet and continue to run perfectly.  The error message doesn't appear on my Win7 machine.  It's no big deal - just wondering if you guys had any idea what was causing it.  

Thanks again,
Chris
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 39801543
It's a bit difficult to know which object it's referring to exactly. I'm assuming it would be in one of the three folder iterations you're looking through, and either that folder doesn't have any items to Restrict (thus found nothing) or the folder itself wasn't found - both theoretical guesses at this point, as there is almost no error handling in the code.

Do what you wish with the points, they're yours, just don't feel obligated to give me any. :)

Zack
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39801548
Chris,

That's great.  A point split is definitely in order since it was Zack who first noticed that I had the commands out of order.

As to the error you're getting, what line is it occurring on?
0
 

Author Comment

by:damoncf1234
ID: 39801812
Zack,

That 'empty folder' idea about the error message makes sense (there are actually 12 different folders - I just put 3 renamed ones on here) - and I'm sure a few of them were empty today.  

BlueDevilFan, I couldn't tell which line they were coming from - the error wasn't one of those line xx, character xx messages - it came up as soon as the outlook window was opened - before I put in the date or excel opened the spreadsheet.  

It was a small box that said that simple message, and sat in the background if you didn't hit ok before putting in a date.  

One thing I just thought about - I have 3 ema profiles on XP - I wonder if that's causing those messages...  I have outlook setup to prompt me for a profile on XP...  
I can get more details on that error message tomorrow.  

Thanks again,
Chris
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39801911
Chris,

What version of Outlook is it on the XP box?
0
 

Author Comment

by:damoncf1234
ID: 39803073
BlueDevilFan,

It's Outlook 2007 on the XP machine
And Outlook 2010 on the Win7 machine

Thanks,
Chris
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 76

Expert Comment

by:David Lee
ID: 39803199
It's tough to figure out what's causing the error when we don't know what line of code it is that's causing it.  I just looked back over the code and I did notice that there's an undefined constant.  I don't know if that's the problem (i.e. the interpreter thinks the constant is an object), but we should fix it anyway.  Please add

Const xlCellTypeConstants = 2

to the other constants defined at the top of the file.
0
 

Author Comment

by:damoncf1234
ID: 39803429
BlueDevilFan,
Ok, I'll add that line to the top of the file (I'm out right now, but should be in later this afternoon to test that out).  
Thank you,
Chris
0
 

Author Comment

by:damoncf1234
ID: 39804680
BlueDevilFan,

I just added that line to the top of the file - it still works without errors on Win7/Office2010, but on an XP machine, it comes up with the same error (it appears before I even get prompted for a date for the schedule (and before Excel Opens)...  

Thanks,
Chris
0
 

Author Comment

by:damoncf1234
ID: 39804858
(The XP machines have Office 2007 on them)
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39806145
Try changing this line

olkSes.Logon olkApp.DefaultProfileName

to

olkSes.Logon "Outlook"
0
 

Author Comment

by:damoncf1234
ID: 39807418
I just changed the line, and it still comes up with that generic error message on Office 2007/XP.  

Since it doesn't come up when run from a Win7 machine running Office 2010, is it something that was changed from the original script (that apparently works in Office 2010 and Win7)?
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39807655
The script shouldn't care whether it's on XP or Win7.  The problem is that we don't know what it is that's causing the error.  Without knowing that, all I can do is guess at what will make it go away.  I don't have an XP computer anymore, so I've no way to test it on that platform.  The best suggestion I have is to make a separate copy of the script (for debugging purposes), then add Msgbox commands to the file, once after each line of code from line 9 to line 27.  Something like this

'--> Turn error handling off
	On Error Resume Next
msgbox "Point A"

'--> Launch Outlook'
	Set olkApp = CreateObject("Outlook.Application")
msgbox "Point B"
	Set olkSes = olkApp.GetNamespace("MAPI")
msgbox "Point C"
	olkSes.Logon olkApp.DefaultProfileName
msgbox "Point D"

Open in new window


Once you have all the msgbox commands in, run the script.  The script will display dialog-box on screen after each command.  The last dialog-box you see before the error will tell us where the error is.  Using the above example, if the error message pops up after a dialog-box containing "Point C", then we know the error is on the next line below that command.  When we know what line it is that's causing the error, then we have a reasonable chance of figuring out what's causing it and how to fix it.
0
 

Author Comment

by:damoncf1234
ID: 39807786
Hahaha...  We still have plenty of XP machines...  
Ok, I'll give that a shot to see what line causes the error.
I'll post back on Monday (since I can't access the other network otuside of work).

Thanks,
Chris
0
 

Author Comment

by:damoncf1234
ID: 39812147
BlueDevilFan,

I just got in (haven't done the MsgBox commands yet), but one thing I noticed later on Friday is that if I have Outlook already open (before running the script), those error messages do not appear.  
The error messages only appear if Outlook is not running before the script is run...  

Thanks,
Chris
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39835212
Chris,

The only reason I can think of that having Outlook open would make the errors go away is if the code is somehow failing to create an instance of Outlook.  Creating a new Outlook instance is exactly what lines 12-14 of the code are designed to do.
0
 

Author Comment

by:damoncf1234
ID: 39835800
BlueDevilFan,

Yes -- what's even stranger is that I went back to our original script (from 2010 or so), and ran it without Outlook open on an XP machine, and the same generic error appeared (but the script still worked fine).  

Since users here have Outlook open 99% of the time, apparently no one has ever seen that error (and we're also migrating from XP to Win7)...  

I guess we can 'ignore' that error on XP if/when anyone sees it.  (No big deal).  The script still works great on XP and Win7, which was the original question for this post...  

We've also started using the updated script daily, and everyone likes it / hasn't complained... :)

Thank you and Zack again for the quick responses and assistance.  

You'd like to split the points equally between you two?  

Thanks,
Chris
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39835946
That's so odd.

A split works for me.
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 39836473
Good to hear the update Chris. I'm a little baffled along with BDF though. The only other thing I would try is a rendition of the code I posted earlier, if you wanted to.

So you'd change this line...
Set olkApp = CreateObject("Outlook.Application")

Open in new window

... to this ...
    On Error Resume Next
    Set olkApp = GetObject(, "Outlook.Application")
    If olkApp Is Nothing Then
        Set olkApp = CreateObject("Outlook.Application")
    End If
    If olkApp Is Nothing Then
        MsgBox "Outlook not found"
        Exit Sub
    End If

Open in new window

I don't think you'll see any difference though. With Outlook open it uses the current instance, and if it's not open it will use the CreateObject() method to create one.

I suspect it would be the Logon code where the failure comes in. I'm assuming you have multiple profiles. If you do not, I'd think about commenting that line out as it's not needed for a single profile. In any case it should work just fine on Win XP though, I've done it a hundred times.

Regarding the points, it's your thread, your points to distribute, but I don't seek anything. BDF is the man of the hour here and I don't need points (certainly not the reason I'm here). Do as you see fit.

Have a great day!

Zack
0
 

Author Comment

by:damoncf1234
ID: 39837378
Zack,

Yes, a few of us here have two Outlook profiles (although I tried changing the Outlook settings to 'not prompt' for the profile when opening, and it didn't seem to make a difference.  (That, and most people's individual profile is named "Outlook", but there's a second account we access from the other profile, which isn't named the same when people setup the secondary account.)

I'll try that modification in the morning and post back about the results.  

Thank you again,
Chris
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 39837412
If you have your Mail settings (in Control Panel) to "Always use this profile" for the selected profile, you shouldn't have to use the Logon method. If you have it prompting you, however, you must set which profile to logon to.

Zack
0
 

Author Comment

by:damoncf1234
ID: 39876803
Zack/BlueDevilFan,

Sorry for the delay (federal government shutdown/got caught-up with other projects/etc.).  

The same generic error appears on XP - but we're about to upgrade our machines and switch to Win7 anyway, so I'm not going to worry about it -- it works fine on Win7/Office2010, and I haven't heard any complaints from anyone...  

Thank you again.  

Chris
0
 

Author Closing Comment

by:damoncf1234
ID: 39876813
Excellent responses by both Zack and BlueDevliFan - both were very responsive and helped with troubleshooting an issue that wasn't part of the original question - thank you again.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39885191
You're welcome, Chris!
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Suggested Solutions

Learn more about how the humble email signature can be used as more than just an electronic business card. When used correctly, a signature can easily be tailored for different purposes by different departments within an organization.
Use email signature images to promote corporate certifications and industry awards.
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now