使用Excel VBA在Outlook中创建提醒

问题描述

试图创建从Excel到Outlook的提醒。我需要将它们发送整整一周的时间，因为该任务将在一周的每一天重复进行，因此我将在周一，周二等提醒您-尚未知道。到目前为止，它只发送了一天，但是我的代码并不出色，它只发送了一个，而没有发送我要为其创建提醒的所有项目。我也有几个类别，每个类别将包含不同数量的任务，例如下面示例中的类别1包含5个项目，但是类别2仅包含3个项目，而类别3包含10个项目

我的数据表

我的代码：

Option Explicit
Public Sub CreateOutlookAppointments()
Sheets("Reminders").Select
On Error GoTo Err_Execute

   Dim olApp As outlook.application
Dim olAppt As Outlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace
Dim CalFolder As Outlook.MAPIFolder
Dim arrCal As String

 
Dim i As Long

On Error Resume Next
Set olApp = outlook.application

If olApp Is nothing Then
    Set olApp = outlook.application
     blnCreated = True
    Err.Clear
Else
    blnCreated = False
End If

On Error GoTo 0

Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
   
Dim LastRow As Long
LastRow = Cells(Rows.Count,19).End(xlUp).Row

For i = 6 To LastRow
If IsDate(Cells(i,19)) And UCase(Trim(Cells(i,21))) <> "ADDED" Then

arrCal = Cells(i,6)
Set olAppt = CalFolder.Items.Add(olAppointmentItem)

'MsgBox subFolder,vbOKCancel,"Folder Name"

With olAppt

'Define calendar item properties
    .Start = Cells(i,19) + Cells(i,20)
    .End = Cells(i,21) + Cells(i,22)
    .Subject = Cells(i,15)
    .Location = Cells(i,16)
    .Body = Cells(i,17)
    .BusyStatus = olBusy
    .ReminderMinutesBeforeStart = Cells(i,23)
    .ReminderSet = True
    .Categories = Cells(i,18)
    .Save
' For meetings or Group Calendars
 ' .Send
End With
   Cells(i,21) = "Added"

End If

Next


Exit Sub

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）