Question

我基本上试图弄清楚如何在Outlook中创建一个宏，允许我创建一个特定类别的约会，然后将约会从用户的本地日历复制到Exchange共享日历（前提是它具有正确的类别）。

有没有人能够更深入地了解Outlook对象模型的运作方式？

由于

Answer 1

以下是一些可能有用的示例代码：

Sub CreateCalEntry(LeadDate As Date, DueDate As Date, _
        Subject As String, Location As String, Body As String, _
        Optional AddToShared As Boolean = True)
Const olApItem = 1

''This example uses late binding, hence object, rather than the commented
''declarations
Dim apOL As Object ''Outlook.Application
Dim oItem As Object ''Outlook.AppointmentItem '
Dim objFolder As Object ''MAPI Folder


    Set apOL = CreateObject("Outlook.Application")
    ''This is the folder to copy to:
    Set objFolder = GetFolder("Public Folders/All Public Folders/Shared Calender")
    Set oItem = apOL.CreateItem(olApItem) ''See const, above

    With oItem
        .Subject = Subject
        .Location = Location
        .Body = Body
        .Start = DueDate

        If AddToShared = True Then
            .Move objFolder
        End If

        .Display
    End With

    Set oItem = Nothing
    Set apOL = Nothing
End Sub

这允许您找到共享文件夹：

Public Function GetFolder(strFolderPath As String) As Object 'MAPIFolder
'' strFolderPath needs to be something like
''   "Public Folders\All Public Folders\Company\Sales" or
''   "Personal Folders\Inbox\My Folder"

Dim apOL As Object ''Outlook.Application
Dim objNS As Object ''Outlook.NameSpace
Dim colFolders As Object ''Outlook.Folders
Dim objFolder As Object ''Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long

On Error GoTo TrapError

    strFolderPath = Replace(strFolderPath, "/", "\")
    arrFolders() = Split(strFolderPath, "\")

    Set apOL = CreateObject("Outlook.Application")
    Set objNS = apOL.GetNamespace("MAPI")


    On Error Resume Next

    Set objFolder = objNS.Folders.Item(arrFolders(0))

    If Not objFolder Is Nothing Then
        For i = 1 To UBound(arrFolders)
            Set colFolders = objFolder.Folders
            Set objFolder = Nothing
            Set objFolder = colFolders.Item(arrFolders(i))

            If objFolder Is Nothing Then
                Exit For
            End If
        Next
    End If

On Error GoTo TrapError

    Set GetFolder = objFolder
    Set colFolders = Nothing
    Set objNS = Nothing
    Set apOL = Nothing

Exit_Proc:
    Exit Function

TrapError:
    MsgBox Err.Number & ": " & Err.Description

End Function

Outlook日历宏（复制约会）

1 个答案: