G
Guest
Sorry, my knownledge about vb is very weak ...
I design my own appointment form. I assigned two self defined field (info1
and info2).
I have to modify vbs script to export all appointments to excel file.
How can I add these fields to export ???
Whole vbs script :
Option Explicit
Sub SaveCalendarToExcel()
'Created by Helen Feddema 9-17-2004
'Last modified 9-17-2004
'Demonstrates pushing Calendar data to rows in an Excel worksheet
On Error GoTo ErrorHandler
Dim appWord As Word.Application
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strTemplatePath As String
Dim i As Integer
Dim j As Integer
Dim lngCount As Long
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
'Must declare as Object because folders may contain different
'types of items
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String
'Pick up Template path from the Word Options dialog
Set appWord = GetObject(, "Word.Application")
strTemplatePath = "C:\"
Debug.Print "Templates folder: " & strTemplatePath
strSheet = "Calendar.xls"
strSheet = strTemplatePath & strSheet
Debug.Print "Excel workbook: " & strSheet
'Test for file in the Templates folder
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Calendar.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Let user select a folder to export
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If
'Test whether selected folder contains contact items
If fld.DefaultItemType <> olAppointmentItem Then
MsgBox "Folder is not a calendar folder"
GoTo ErrorHandlerExit
End If
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No appointments to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " appointments to export"
End If
'Adjust i (row number) to be 1 less than the number of the first body row
i = 3
'Iterate through contact items in Calendar folder, and export a few fields
'from each item to a row in the Calendar worksheet
For Each itm In fld.Items
If itm.Class = olAppointment Then
'Process item only if it is an appointment item
i = i + 1
'j is the column number
j = 1
Set rng = wks.Cells(i, j)
If itm.Start <> "" Then rng.Value = itm.Start
j = j + 1
Set rng = wks.Cells(i, j)
If itm.End <> "" Then rng.Value = itm.End
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Duration <> "" Then rng.Value = itm.Duration
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Subject <> "" Then rng.Value = itm.Subject
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Location <> "" Then rng.Value = itm.Location
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Categories <> "" Then rng.Value = itm.Categories
j = j + 1
Set rng = wks.Cells(i, j)
If itm.IsRecurring <> "" Then rng.Value = itm.Organizer
j = j + 1
Set rng = wks.Cells(i, j)
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
If itm.UserProperties("CustomField") <> "" Then
rng.Value = itm.UserProperties("CustomField")
End If
j = j + 1
End If
i = i + 1
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
'Application object is not set by GetObject; use CreateObject instead
If appWord Is Nothing Then
Set appWord = CreateObject("Word.Application")
Resume Next
ElseIf appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub
Public Function TestFileExists(strFile As String) As Boolean
'Created by Helen Feddema 9-1-2004
'Last modified 9-1-2004
'Tests for existing of a file, using the FileSystemObject
Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File
On Error Resume Next
Set fil = fso.GetFile(strFile)
If fil Is Nothing Then
TestFileExists = False
Else
TestFileExists = True
End If
End Function
I design my own appointment form. I assigned two self defined field (info1
and info2).
I have to modify vbs script to export all appointments to excel file.
How can I add these fields to export ???
Whole vbs script :
Option Explicit
Sub SaveCalendarToExcel()
'Created by Helen Feddema 9-17-2004
'Last modified 9-17-2004
'Demonstrates pushing Calendar data to rows in an Excel worksheet
On Error GoTo ErrorHandler
Dim appWord As Word.Application
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strTemplatePath As String
Dim i As Integer
Dim j As Integer
Dim lngCount As Long
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
'Must declare as Object because folders may contain different
'types of items
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String
'Pick up Template path from the Word Options dialog
Set appWord = GetObject(, "Word.Application")
strTemplatePath = "C:\"
Debug.Print "Templates folder: " & strTemplatePath
strSheet = "Calendar.xls"
strSheet = strTemplatePath & strSheet
Debug.Print "Excel workbook: " & strSheet
'Test for file in the Templates folder
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Calendar.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If
Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Let user select a folder to export
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If
'Test whether selected folder contains contact items
If fld.DefaultItemType <> olAppointmentItem Then
MsgBox "Folder is not a calendar folder"
GoTo ErrorHandlerExit
End If
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No appointments to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " appointments to export"
End If
'Adjust i (row number) to be 1 less than the number of the first body row
i = 3
'Iterate through contact items in Calendar folder, and export a few fields
'from each item to a row in the Calendar worksheet
For Each itm In fld.Items
If itm.Class = olAppointment Then
'Process item only if it is an appointment item
i = i + 1
'j is the column number
j = 1
Set rng = wks.Cells(i, j)
If itm.Start <> "" Then rng.Value = itm.Start
j = j + 1
Set rng = wks.Cells(i, j)
If itm.End <> "" Then rng.Value = itm.End
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Duration <> "" Then rng.Value = itm.Duration
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Subject <> "" Then rng.Value = itm.Subject
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Location <> "" Then rng.Value = itm.Location
j = j + 1
Set rng = wks.Cells(i, j)
If itm.Categories <> "" Then rng.Value = itm.Categories
j = j + 1
Set rng = wks.Cells(i, j)
If itm.IsRecurring <> "" Then rng.Value = itm.Organizer
j = j + 1
Set rng = wks.Cells(i, j)
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
If itm.UserProperties("CustomField") <> "" Then
rng.Value = itm.UserProperties("CustomField")
End If
j = j + 1
End If
i = i + 1
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err.Number = 429 Then
'Application object is not set by GetObject; use CreateObject instead
If appWord Is Nothing Then
Set appWord = CreateObject("Word.Application")
Resume Next
ElseIf appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub
Public Function TestFileExists(strFile As String) As Boolean
'Created by Helen Feddema 9-1-2004
'Last modified 9-1-2004
'Tests for existing of a file, using the FileSystemObject
Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File
On Error Resume Next
Set fil = fso.GetFile(strFile)
If fil Is Nothing Then
TestFileExists = False
Else
TestFileExists = True
End If
End Function