Question

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

我已经为此编写了代码，但是我的问题是它继续创建与先前编码的数据相同的约会-简单地说，同一天重复的约会具有相同的数据。

例如：我已经对名称“ Allen”进行了编码，它将在2019年1月1日创建一个约会。下一次对另一个数据进行编码时，将在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

Answer 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 !"

结束字幕

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

用户窗体将对数据进行编码，并将在Microsoft Outlook日历上创建约会

1 个答案: