Question

我创建了宏来自动创建新的日历约会并在Outlook 2010中编辑现有的日历约会。

自升级到Outlook 2013以来，宏不再有效。我没有收到任何错误消息。

Sub NewCustomAppt()
'objects
Dim objExpl As Outlook.Explorer
Dim objFolder As Outlook.MAPIFolder
Dim objCB As Office.CommandBarButton
'appointment
Dim objAppt As Outlook.AppointmentItem
Dim objApptCustom As Outlook.AppointmentItem
Dim objOutlookAttach As Outlook.Attachment

Dim objNS

Set objNS = Application.GetNamespace("MAPI")

On Error Resume Next

Set objExpl = Application.ActiveExplorer

If Not objExpl Is Nothing Then
    Set objFolder = objExpl.CurrentFolder
    If objFolder.DefaultItemType = olAppointmentItem Then
        Set objCB = objExpl.CommandBars.FindControl(, 1106)
        If Not objCB Is Nothing Then
            objCB.Execute
            Set objAppt = Application.ActiveInspector.CurrentItem
            Set objApptCustom =   
            objFolder.Items.Add("IPM.Appointment.your_custom_class")

            Set objSel = objDoc.Windows(1).Selection

            With objApptCustom
                .Start = objAppt.Start
                .End = objAppt.End            

                objAppt.Location = "Careers Service, Level 6 Livingstone Tower"
                objAppt.ReminderSet = True
                objAppt.ReminderMinutesBeforeStart = 4320

                objAppt.Body = "If you wish to cancel or re-schedule this    
                    appointment please let us know as soon as possible, by telephone:          
                     0141 548 4320 or email: yourcareer@strath.ac.uk." & vbNewLine & _
                    "" & vbNewLine & _
                    "Please make sure you are prompt for your appointment, if you are 
                     more than 10 minutes late you will not be seen by the adviser." 
                     & vbNewLine & _
                     & vbNewLine & _
                     & vbNewLine & _
                     "Your Careers Adviser for this appointment is:" & vbNewLine & _
                     "" & vbNewLine & _
                     "" & vbNewLine & _
                     In order to prepare for your appointment with your Careers Adviser 
                     please read through the information attached below" 
                     & vbNewLine & _
                     "" & vbNewLine & _
                  "" & vbNewLine & _
                  "" & vbNewLine & _
                  "" & vbNewLine & _
                  "" & vbNewLine & _
                    "This appointment was created on the " & Date & " at" & " " & Time 
                     & vbNewLine & _
                     objAppt.Attachments.Add "I:\Admin\Careers\INTERVIEW.DOC
                     'Add the attachment to the e-mail message.

                End With
            End If
        End If
    End If
End Sub

Answer 1

来自Microsoft：

Outlook 2013中未使用命令栏.CommandBar函数将以静默方式失败。

在Outlook 2013加载项中使用IRibbonExtensibility接口而不是命令栏。您无法使用表单后面的VBScript代码自定义Inspector功能区。

http://technet.microsoft.com/en-us/library/cc178954%28v=office.15%29.aspx

Answer 2

.FindControl（，1106）在2010年有效，所以如果在2013年出现静默失败，请切换到ExecuteMso

http://msdn.microsoft.com/en-us/library/ff862419.aspx

Private Sub NewCustomAppt_ExecuteMso()

    'objects
    Dim objExpl As Outlook.Explorer
    Dim objFolder As Outlook.Folder

    'appointment
    Dim objAppt As Outlook.AppointmentItem
    Dim objOutlookAttach As Outlook.attachment

    Dim objNS
    Set objNS = Application.GetNamespace("MAPI")

    Set objExpl = Application.ActiveExplorer

    If Not objExpl Is Nothing Then

        Set objFolder = objExpl.CurrentFolder

        If objFolder.DefaultItemType = olAppointmentItem Then

            objExpl.CommandBars.ExecuteMso ("NewAppointment") ' <----
            Set objAppt = Application.ActiveInspector.CurrentItem

            objAppt.location = "Careers Service, Level 6 Livingstone Tower"
            objAppt.ReminderSet = True
            objAppt.ReminderMinutesBeforeStart = 4320

            objAppt.body = "If you wish to cancel or re-schedule this "

        End If

    End If

End Sub

如果在修改色带或QAT时将鼠标悬停在命令上，则可以看到IdMso。

在Outlook 2013中应用CommandBars功能

2 个答案: