0

実行している 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
4

2 に答える 2

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
于 2012-06-18T14:35:33.503 に答える
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 を閉じていると明らかに遅くなります)。

サンプル アプリ

実際、Outlook が開いているかどうかを確認する必要はありません。

于 2012-06-18T16:22:57.537 に答える