将Outlook 2003共享日历信息发送到Excel电子表格的代码

Sub ExportCalendarToExcel()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olItem As Outlook.AppointmentItem
    Dim xlApp As Excel.Application
    Dim xlWorkbook As Excel.Workbook
    Dim xlWorksheet As Excel.Worksheet
    Dim row As Integer
    
    ' 创建Outlook应用程序对象
    Set olApp = New Outlook.Application
    ' 获取Outlook命名空间
    Set olNamespace = olApp.GetNamespace("MAPI")
    ' 获取日历文件夹
    Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    ' 获取日历项集合
    Set olItems = olFolder.Items
    
    ' 创建Excel应用程序对象
    Set xlApp = New Excel.Application
    ' 创建新的工作簿
    Set xlWorkbook = xlApp.Workbooks.Add
    ' 获取第一个工作表
    Set xlWorksheet = xlWorkbook.Worksheets(1)
    
    ' 设置Excel表头
    xlWorksheet.Cells(1, 1).Value = "Subject"
    xlWorksheet.Cells(1, 2).Value = "Start Time"
    xlWorksheet.Cells(1, 3).Value = "End Time"
    xlWorksheet.Cells(1, 4).Value = "Location"
    
    ' 遍历日历项并将信息写入Excel表格
    row = 2
    For Each olItem In olItems
        xlWorksheet.Cells(row, 1).Value = olItem.Subject
        xlWorksheet.Cells(row, 2).Value = olItem.Start
        xlWorksheet.Cells(row, 3).Value = olItem.End
        xlWorksheet.Cells(row, 4).Value = olItem.Location
        row = row + 1
    Next olItem
    
    ' 保存Excel文件
    xlWorkbook.SaveAs "C:\Path\To\Your\File.xlsx"
    
    ' 关闭Excel应用程序
    xlWorkbook.Close
    xlApp.Quit
    
    ' 释放对象
    Set xlWorksheet = Nothing
    Set xlWorkbook = Nothing
    Set xlApp = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub