0

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

ただし、いくつかの異常があります。

  1. 該当する行の2列目と3列目に書かれている内容が「件名」に設定されているとは限りません。リマインダーに空白を返すだけです。
  2. 列Lが「隔離」または「検査」と表示されている場合、リマインダーを作成しないでください。どんな助けでも感謝します。

Excel ワークブックへのリンクは次のとおりですhttp://db.tt/Goqni3uf

4

1 に答える 1

0

あなたがそれを機能させてよかった:)

次のリクエストでは、この条件の間にコードを埋め込みます

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
于 2012-08-06T23:17:13.357 に答える