宏无法基于工作表数据创建约会

2 回答

• 0

  在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 .

  回复于 2024-04-25T12:17:11+08:00
• 0

  代替

  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
  

  回复于 2024-04-25T12:17:11+08:00