Question

我运行以下代码以在Outlook中创建提醒。

' requires a reference to the Microsoft Outlook          x.0 Object Library
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
DeleteTestAppointments ' deletes previous test appointments
On Error Resume Next
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 = 5 ' first row with appointment data in the active worksheet
While Len(Cells(r, 5).Formula) > 0
Set olAppItem =     olApp.CreateItem(olAppointmentItem) ' creates a    new appointment
With olAppItem
    ' set default appointment values
    On Error Resume Next
    .Start = Cells(r, 9).Value
    .End = Cells(r, 9)
    .Subject = Cells(r, 2).Value + Cells(r,        3).Value
    .Location = Cells(r, 5).Value
    .Body = Cells(r, 9).Value
    .ReminderSet = True
    .ReminderMinutesBeforeStart = 20160
    .Categories = "TestAppointment" ' 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
End Sub

Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
On Error Resume Next
Set olApp = GetObject("",     "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = GetObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    MsgBox "Outlook is not available!"
    Exit Sub
End If
End If
Set OLF =    olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
dCount = 0
For r = OLF.Items.Count To 1 Step -1
If TypeName(OLF.Items(r)) = "AppointmentItem" Then
    If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
        OLF.Items(r).Delete
        dCount = dCount + 1
    End If
End If
Next r
Set olApp = Nothing
Set OLF = Nothing
End Sub

但是我有几个异常;

并不总是将“主题”设置为相关行的第2列和第3列中的内容。它只会在提醒中返回一个空白。
如果L栏显示“隔离”或“检查”，我希望不创建提醒。任何帮助都将不胜感激。

以下是excel工作簿http://db.tt/Goqni3uf

Answer 1

很高兴你得到它的工作：）

对于下一个请求，请将您的代码嵌入此条件

While Len(Cells(r, 5).Formula) > 0
    Select Case LCase(Cells(r, 12).Value)
        Case "quarantined", "inspected"
        Case Else
            '
            '~~> Your code to create an appointment
            '
    End Select
Wend

从Excel代码问题的Outlook提醒

1 个答案: