Question

我在Windows 7上使用Outlook 2007.我最近安装的iCloud很遗憾地意识到Google Calendar Sync只会同步默认日历。我想知道是否有人可以用一个简单的VBA宏来帮助我

清空所有约会的默认日历
将所有约会从iCloud日历复制到默认日历

非常感谢！

Answer 1

健康警告

这个答案中的所有内容都是通过实验发现的。我从VB帮助开始，使用F2访问对象模型并进行实验，直到找到有效的方法。我确实购买了一本备受推荐的参考书，但它没有包含任何重要内容，我没有发现并省略了我发现的内容。

我怀疑我获得的知识的一个关键特征是它基于许多不同的安装。遇到的一些问题可能是安装错误的结果，这可以解释为什么参考书作者不知道它们。

下面的代码已经过Outlook 2003测试。我已经使用Outlook 2007测试了类似的代码。

将默认日历中约会的所选属性输出到立即窗口

您报告此例程的第一个版本发出错误：＆＃34;运行时错误＆＃39; -2147467259（80004005）＆＃39;：您必须输入正数持续时间。＆＃34;

根据我在Google上找到的网站，错误80004005表示系统文件已损坏。

约会有三个相关项：开始（键入日期），结束（键入日期）和持续时间（类型长）。我假设End或Duration是在运行时派生的。我的猜测是，持续时间是负数，或者结束是在开始之前。我注意到在我的系统上由此宏创建的约会列表中，某些全天事件具有属性AllDayEvent = False。我似乎记得我曾经发现创建一个约会，然后打开或关闭AllDayEvent会造成不一致。

我添加了试图检测此问题的代码，但我无法测试它，因为我没有在我的系统上发出此错误的约会。这个宏只是为了让你开始列出你当前的约会，所以如果你不能让它工作，我们不用担心。

Sub ReviewCalendar()

  Dim DateTimeEnd As Date
  Dim DateTimeStart As Date
  Dim Duration As Long
  Dim ItemMine As Object
  Dim ItemMineClass As Long
  Dim FolderTgt As MAPIFolder

  Set FolderTgt = CreateObject("Outlook.Application"). _
                   GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)

  ' I use this macro to list selected properties from the test calendar.
  ' Add a quote to the statement above and remove the quote from the next
  ' statement to do the same.
  'Set FolderTgt = CreateObject("Outlook.Application"). _
                    GetNamespace("MAPI").Folders("Test Folders"). _
                    Folders("Calendar")

  For Each ItemMine In FolderTgt.Items

    With ItemMine

      ' Occasionally I get syncronisation
      ' errors.  This code avoids them.
      ItemMineClass = 0
      On Error Resume Next
      ItemMineClass = .Class
      On Error GoTo 0

      If ItemMineClass = olAppointment Then
        Debug.Print "** Subject: " & .Subject
        Debug.Print "   Created: " & _
                         Format(.CreationTime, "d mmm yy hh:mm:ss")
        Debug.Print "   Updated: " & _
                         Format(.LastModificationTime, "d mmm yy hh:mm:ss")
        Debug.Print "   Time: ";
        DateTimeStart = .Start
        If .AllDayEvent Then
          Debug.Print "All day " & Format(.Start, "d mmm yy")
        Else
          On Error Resume Next
          DateTimeEnd = .End
          Duration = .Duration
          On Error GoTo 0
          If Duration <= 0 Then
            Debug.Print "  ##### Invalid duration #####"
          End If
          Debug.Print Format(.Start, "h:mm") & " to " & _
                      Format(.End, "h:mm") & "(" & .Duration & _
                      " minutes) on " & Format(.Start, "d mmm yy")
        End If
        ' If you remove the quote from the following statement
        ' it will delete the appointment.
        ' .Delete       ' Delete appointment
      End If
    End With
  Next

End Sub

准备测试约会的复制

我建议你创建一个测试文件夹，这样你就可以在不影响任何重要事项的情况下测试宏。

从工具栏中，选择文件，新建，Outlook数据文件，Office Outlook个人文件夹文件（.pst）。
出现一个列出现有PST文件的窗口。在我的系统上，这些是：archive.pst，Outlook.pst和Test.pst。
在底部选择默认文件名。输入＆＃34;测试＆＃34;或您选择的其他名称。
出现另一个窗口，您可以（1）在Outlook资源管理器窗口中选择用于新个人文件夹的名称，以及（2）选择加密级别。输入＆＃34;测试＆＃34;或您选择的其他名称。（Outlook将添加＆＃34;文件夹＆＃34;到您的名字。）我不加密或密码保护我的系统上的消息，但这是您的选择。
从工具栏中，选择“转到”，“文件夹列表”。文件夹列表将显示在“输出资源管理器”窗口的位置。
右键单击文件夹＆＃34;日历＆＃34;然后选择新文件夹。将出现“新建文件夹”窗口。
输入名称为＆＃34;日历＆＃34;并选择“测试文件夹”作为其位置。

现在，当您选择日历时，您将获得＆＃34;测试文件夹中的日历＆＃34;作为一个额外的选择。

将约会从默认日历复制到测试日历

此宏在默认日历中每个约会的测试日历中创建一个副本运行一次然后选择Calandar并勾选默认和测试日历。这两个日历应该完全相同。

警告：如果再次运行宏，您将以每个约会的两个副本结束。

Sub CopyCalendar()

  Dim FolderDest As MAPIFolder
  Dim ItemCopy As AppointmentItem
  Dim ItemMine As Object
  Dim ItemMineClass As Long
  Dim NameSpaceMine As NameSpace
  Dim FolderSrc As MAPIFolder

  Set NameSpaceMine = _
          CreateObject("Outlook.Application").GetNamespace("MAPI")

  With NameSpaceMine
    Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
    Set FolderDest = .Folders("Test Folders").Folders("Calendar")
  End With

  Debug.Print FolderSrc.Items.Count
  Debug.Print FolderDest.Items.Count

  For Each ItemMine In FolderSrc.Items

    With ItemMine

      ' Occasionally I get syncronisation
      ' errors.  This code avoids them.
      ItemMineClass = 0
      On Error Resume Next
      ItemMineClass = .Class
      On Error GoTo 0

      ' I have never found anything but appointments in
      ' Calendar but test just in case
      If ItemMineClass = olAppointment Then
        Set ItemCopy = .Copy
        ItemCopy.Move FolderDest
      End If

    End With

  Next

End Sub

后续步骤

Set FolderDest语句显示如何通过降低其层次结构来选择partcular文件夹。还有其他更通用的技术，但如果您能以这种方式访问iClound日历，这应该足以满足您的要求。

 Set NameSpaceMine = _
          CreateObject("Outlook.Application").GetNamespace("MAPI")

  With NameSpaceMine
    Set FolderDest = .Folders("Test Folders").Folders("Calendar")
  End With

第一个宏包括删除日历中每个约会的代码，第二个宏包含从一个日历到另一个日历的约会。

组合和调整此代码将为您提供单向同步。也就是说，它会使日历2成为日历1的副本。这是否足够？用默认日历覆盖iCloud日历是否足够？双向同步更复杂。我经历了几次＆＃34;企业＆＃34;同步例程，没有一个是万无一失的。如果您属于＆＃34;企业意味着价格过高，质量差的软件＆＃34;上学，你不会感到惊讶。否则，您可能同意双向同步很困难，或者两个陈述都是正确的。

问题是：

可能会更改任一日历中的非标识属性。
可以在任一日历中添加或删除约会。
可以更改任一日历中的标识属性。通常，主题和/或开始时间是识别属性，但可以更改主题并且可以移动约会。

在我的系统上，CreationTime和LastModificationTime被复制，因此可以选择将它们用作标识符。由于会议请求，我无法测试正在更新的日历对CreationTime和LastModificationTime的影响。

我让您考虑这些问题，并决定如何推进此事。

Outlook 2007宏将复制约会从iCloud日历复制到默认日历

1 个答案: