Question

我正在尝试在列＃34; E＆＃34;中导入日期。到我的Outlook日历。

我已经启动了代码，但它只是在我的日历中添加了某些日期，并没有添加像我这样的多个日期。 6/2的日期被添加到我的日历中，主题日期和正文正确，但对于6/1的日期，我有一个空位。

Option Explicit
Public Sub CreateOutlookApptz()
   Sheets("Sheet2").Select
    On Error GoTo Err_Execute

    Dim olApp As OUtlook.Application
    Dim olAppt As OUtlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As OUtlook.Namespace
    Dim CalFolder As OUtlook.MAPIFolder
    Dim subFolder As OUtlook.MAPIFolder
    Dim arrCal As String

    Dim i As Long

    On Error Resume Next
    Set olApp = OUtlook.Application

    If olApp Is Nothing Then
        Set olApp = OUtlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If

    On Error GoTo 0

    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)

    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""

    Set subFolder = CalFolder

    Set olAppt = subFolder.Items.Add(olAppointmentItem)

    MsgBox Cells(i, 6) + Cells(i, 7)

    'MsgBox subFolder, vbOKCancel, "Folder Name"

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 6) + Cells(i, 7)
        .End = Cells(i, 8) + Cells(i, 9)
        .Subject = Cells(i, 2)
        .Location = Cells(i, 3)
        .Body = Cells(i, 4)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 10)
        .ReminderSet = True
        .Categories = Cells(i, 5)
        .Save

    End With

        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing

    Exit Sub

Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."

End Sub

Answer 1

以这种方式试试。

Private Sub Add_Appointments_To_Outlook_Calendar()

    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oAppt As AppointmentItem
    Dim Remind_Time As Double

    i = 2
    Subj = ThisWorkbook.Sheets(1).Cells(i, 1)

    'Loop through entire list of Reminders to be added
    While Subj <> ""
        Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)

        oAppt.Subject = Subj
        oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
        oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
        Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
        oAppt.ReminderMinutesBeforeStart = Remind_Time
        oAppt.AllDayEvent = True
        oAppt.Save

        i = i + 1
        Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
    Wend
    MsgBox "Reminder(s) Added To Outlook Calendar"

End Sub

您的设置将如下所示。

我在书中谈到了这个概念以及许多其他相似但不同的东西。

https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC?ie=UTF8&keywords=ryan%20shuell&qid=1464361126&ref_=sr_1_1&sr=8-1

将日期从Excel导入Outlook日历

1 个答案: