Макрос не удается создать встречи на основе данных рабочего листа

Question

У меня есть макрос Excel, который я запускаю, который принимает имена активности, даты и время из электронной таблицы и помещает их в календарь Outlook. Это отлично работает, когда Outlook работает, но когда это не так, макрос не назначает встречи.

Я проверил элемент проверки ошибок, который проверяет, работает ли запущенный экземпляр Outlook и если он его не создает, но он все еще работает только при запуске Outlook.

Любые идеи, почему?

Sub SetAppt() 
    ' Dim olApp As Outlook.Application 
    Dim olApt As AppointmentItem 
    Dim olApp As Object 

    'if an instance of outlook is not open then create an instance of the application 
    On Error Resume Next 
    Set olApp = GetObject(, "Outlook.Application") 

    If er.Number = 429 Then 
     Set olApp = CreateObject("Outlook.Application.14") 
    End If 

    On Error GoTo 0 

    Set olApp = CreateObject("Outlook.Application") 
    ' Set olApp = New Outlook.Application 

    'declare an index for all the variables 
    Dim i As Integer 
    i = 2 

    'declare the variables that will hold the data and set their initial value 
    Dim occ, actName, srtTime, duration As String 
    occ = "A" & i 
    actName = "B" & i 
    srtTime = "F" & i 
    duration = "G" & i 

    'for holding different parts of the dates/times that will be split 
    Dim splitStr() As String 
    Dim splitDrtion() As String 

    'loop until there is no more items 
    While Range(occ).Value <> "" 

     'create a new appointment 
     Set olApt = olApp.CreateItem(olAppointmentItem) 

     'we must split the start time and date 
     splitStr = Split(Range(srtTime).Value, " ") 

     Dim oDate As Date 
     oDate = splitStr(0) 

     'we must also spilt the duration (number/hour) 
     splitDrtion = Split(Range(duration).Value, " ") 

     'with is used to acces the appointment items properties 
     With olApt 

      .Start = oDate + TimeValue(splitStr(1)) 

      'if the duration is in hours then multiply number else leave it 
      If splitDrtion(1) = "Hour" Then 
      .duration = 60 * splitDrtion(0) 
      Else 
      .duration = splitDrtion(0) 
      End If 

      .Subject = Range(occ).Value 
      .Body = Range(actName).Value 
      .Save 
     End With 

     'increment i and reset all the variables with the new number 
     i = i + 1 
     occ = "A" & i 
     actName = "B" & i 
     srtTime = "F" & i 
     duration = "G" & i 

     Set olApt = Nothing 
     Wend 
     Set olApp = Nothing 
End Sub 

Answer 1

Строительство на примере Siddharth «s, здесь рефакторинга версия кода.

Sub SetAppt() 
    Dim olApt As Object ' Outlook.AppointmentItem 
    Dim olApp As Object ' Outlook.Application 
    Dim i As Long 
    Dim apptRange As Variant 

    Const olAppointmentItem As Long = 1 

    ' create outlook 
    Set olApp = GetOutlookApp 

    If olApp Is Nothing Then 
    MsgBox "Could not start Outlook" 
    Exit Sub 
    End If 

    ' read appts into array 
    apptRange = Range(Cells(2, 1), Cells(Rows.Count, 7).End(xlUp)).value 

    For i = LBound(apptRange) To UBound(apptRange) 
    Set olApt = olApp.CreateItem(olAppointmentItem) 
    With olApt 
     .Start = apptRange(i, 6) 
     If InStr(apptRange(i, 7), "Hour") > 0 Then 
     ' numeric portion cell is delimited by space 
     .Duration = 60 * Split(apptRange(i, 7), " ")(0) 
     Else 
     .Duration = apptRange(i, 7) 
     End If 

     .Subject = apptRange(i, 1) 
     .Body = apptRange(i, 2) 
     .Save 
    End With 
    Next i 

End Sub 
Function GetOutlookApp() As Object 
    On Error Resume Next 
    Set GetOutlookApp = CreateObject("Outlook.Application") 
End Function 

Этот код считывает данные вашего рабочего листа в массив. Это позволяет избежать штрафных санкций, возникающих в результате взаимодействия COM между VBA и Excel.

Мы прокручиваем массив и создаем новую встречу для каждой строки.

Используя следующие данные образца, он работал независимо от того, был ли Outlook открытым или нет (однако закрытие Outlook делает его явно более медленным).

Существует на самом деле no need to check if Outlook is open.

Answer 2

Вместо

On Error Resume Next 
Set olApp = GetObject(, "Outlook.Application") 

If er.Number = 429 Then 
    Set olApp = CreateObject("Outlook.Application.14") 
End If 

On Error GoTo 0 

Set olApp = CreateObject("Outlook.Application") 

Попробуйте

On Error Resume Next 
Set olApp = GetObject(, "Outlook.Application") 

'~~> If not found then create new instance 
If Err.Number <> 0 Then 
    Set olApp = CreateObject("Outlook.Application") 
End If 
Err.Clear 
On Error GoTo 0 

Поскольку я не могу проверить это, вот ваш код с необходимыми обновлениями. Пожалуйста, попробуйте это.

Sub SetAppt() 
    Dim olApt As Object, olApp As Object 
    Dim i As Integer 
    Dim occ As String, actName As String, srtTime As String, duration As String 
    Dim splitStr() As String, splitDrtion() As String 
    Dim oDate As Date 

    On Error Resume Next 
    Set olApp = GetObject(, "Outlook.Application") 

    '~~> If not found then create new instance 
    If Err.Number <> 0 Then 
     Set olApp = CreateObject("Outlook.Application") 
    End If 
    Err.Clear 
    On Error GoTo 0 

    'declare an index for all the variables 
    i = 2 

    'declare the variables that will hold the data and set their initial value 
    occ = "A" & i 
    actName = "B" & i 
    srtTime = "F" & i 
    duration = "G" & i 

    'loop until there is no more items 
    While Range(occ).Value <> "" 
     'create a new appointment 
     Set olApt = olApp.CreateItem(1) 

     'we must split the start time and date 
     splitStr = Split(Range(srtTime).Value, " ") 

     oDate = splitStr(0) 

     'we must also spilt the duration (number/hour) 
     splitDrtion = Split(Range(duration).Value, " ") 

     'with is used to acces the appointment items properties 
     With olApt 

      .Start = oDate + TimeValue(splitStr(1)) 

      'if the duration is in hours then multiply number else leave it 
      If splitDrtion(1) = "Hour" Then 
       .duration = 60 * splitDrtion(0) 
      Else 
       .duration = splitDrtion(0) 
      End If 

      .Subject = Range(occ).Value 

      .Body = Range(actName).Value 
      .Save 
     End With 

     'increment i and reset all the variables with the new number 
     i = i + 1 
     occ = "A" & i 
     actName = "B" & i 
     srtTime = "F" & i 
     duration = "G" & i 

     Set olApt = Nothing 
    Wend 

    Set olApp = Nothing 
End Sub