宏未能根據工作表數據創建約會

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的例子，這裏是你的代碼的重構的版本。

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 

此代碼將您的工作表數據讀入數組。這避免了VBA和Excel之間的COM交互造成的時間損失。

我們遍歷數組併爲每行創建一個新約會。

使用以下示例數據，無論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