Userform 将对数据进行编码并在 Microsoft Outlook 日历上创建约会答案

【问题标题】：Userform will encode data and will create an appointment on Microsoft Outlook CalendarUserform 将对数据进行编码并在 Microsoft Outlook 日历上创建约会
【发布时间】：2019-01-26 05:01:08
【问题描述】：

我已经制作了一个可以在电子表格上编码数据的用户表单。除了它的功能之外，我还想在单击用户窗体上的按钮时在 Microsoft Outlook 日历上创建一个约会。

我为此编写了代码，但我的问题是它不断创建与以前编码的数据相同的约会 - 简单地说，同一天有重复的约会，使用相同的数据。

例如：我已经对名称“Allen”进行了编码，它将在 2019 年 1 月 1 日创建一个约会。下次 a 对另一个数据进行编码时，将在 2019 年 1 月 1 日有另一个名为“Allen”的约会。

这是我目前使用的代码：

Private Sub CommandButton1_Click()

lMaxRows = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
lMaxRows = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
lMaxRows = Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
lMaxRows = Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row

Sheets("Sheet1").Range("A" & lMaxRows + 1).Value = TextBox1
Sheets("Sheet1").Range("B" & lMaxRows + 1).Value = TextBox2
Sheets("Sheet1").Range("C" & lMaxRows + 1).Value = TextBox3
Sheets("Sheet1").Range("D" & lMaxRows + 1).Value = "9:00"

Dim oAppt As AppointmentItem
Dim Remind_Time As Double

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

While Candidate <> ""
    Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)

        oAppt.Subject = Candidate + " " + ThisWorkbook.Sheets(1).Cells(i, 2)
        oAppt.Location = ""
        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
    Candidate = ThisWorkbook.Sheets(1).Cells(i, 1)
Wend
MsgBox "Candidate(s) Added To Outlook Calendar!"
End Sub

【问题讨论】：

您正在使用循环来创建约会，因此每次调用代码时它都会遍历所有行。如果您只需要创建一个约会，请不要使用循环。
感谢您的回答@TimWilliams。这意味着我需要删除“While”和“Wend”，对吧？
是的，整个使用i。只需引用您刚刚填充的行。
谢谢队友@TimWilliams！它现在运行良好！

标签： vba outlook calendar

【解决方案1】：

请尝试清除 Outlook 应用程序对象，如下所示：

设置 olAppItem = 无

设置 olApp = 无

Sub RegisterAppointmentList() 
' adds a list of appontments to the Calendar in Outlook 
Dim olApp As Outlook.Application 
Dim olAppItem As Outlook.AppointmentItem 
Dim r As Long 

On Error Resume Next 
Worksheets("Schedule").Activate 

Set olApp = GetObject("", "Outlook.Application") 
On Error GoTo 0 
If olApp Is Nothing Then 
    On Error Resume Next 
    Set olApp = CreateObject("Outlook.Application") 
    On Error GoTo 0 
    If olApp Is Nothing Then 
        MsgBox "Outlook is not available!" 
        Exit Sub 
    End If 
End If 
r = 6 ' first row with appointment data in the active worksheet 
Dim mysub, myStart, myEnd 
While Len(Cells(r, 2).Text) <> 0 
    mysub = Cells(r, 2) & ", " & Cells(r, 3) 
    myStart = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value 
    myEnd = DateValue(Cells(r, 5).Value) + Cells(r, 7).Value 
    'DeleteTestAppointments mysub, myStart, myEnd 
    Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment 
    With olAppItem 
        ' set default appointment values 
        .Location = Cells(r, 3) 
        .Body = "" 
        .ReminderSet = True 
        .BusyStatus = olFree 
        '.RequiredAttendees = "johndoe@microsoft.com" 
        On Error Resume Next 
        .Start = myStart 
        .End = myEnd 
        .Subject = Cells(r, 2) & ", " & .Location 
        .Attachments.Add ("c:\temp\somefile.msg") 
        .Location = Cells(r, 3).Value 
        .Body = .Subject & ", " & Cells(r, 4).Value 
        .ReminderSet = True 
        .BusyStatus = olBusy 
        .Categories = "Orange Category" ' add this to be able to delete the testappointments 
        On Error GoTo 0 
        .Save ' saves the new appointment to the default folder 
    End With 
    r = r + 1 
Wend 
Set olAppItem = Nothing 
Set olApp = Nothing 
MsgBox "Done !"

结束子

另外，您是否为编码数据设置了正确的时间或使用硬编码测试数据来创建约会？希望对你有帮助。

【讨论】：