用户窗体将对数据进行编码，并将在Microsoft Outlook日历上创建约会 [英] Userform will encode data and will create an appointment on Microsoft Outlook Calendar

问题描述

我已经制作了一个用户表单，可以对电子表格中的数据进行编码.除了其功能外，我还想通过单击用户窗体上的按钮在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

解决方案

请尝试清除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 = "[e-mail]" 
        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 !" 

结束字幕

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

I have already made a User Form which could encode data on a spreadsheet. In addition to its feature, I would want to create an appointment on Microsoft Outlook Calendar upon clicking a button on the userform.

I have coded for this, but my problem is that it keeps on creating the same appointment of previous data encoded - simply say, there are duplications of appointment on the same day, with the same data.

For example: I have encoded the Name "Allen" and it will create an appointment on January 1, 2019. The next time a have encoded another data, there will be another appointment on January 1, 2019 with Name "Allen".

This is the code that i am currently using:

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

解决方案

Please try clear the Outlook application object, like this below:

Set olAppItem = Nothing

Set olApp = Nothing

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 = "[e-mail]" 
        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 !" 

End Sub

Also, did you set the right time for your encoded data or use hard code test data to create appointment? Hope it helps you.

这篇关于用户窗体将对数据进行编码，并将在Microsoft Outlook日历上创建约会的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！