【会員アンケートご協力のお願い】抽選で計5名様に役立つ書籍をプレゼント!

Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 11全般 : 指定なし)
Outlook 削除
投稿日時: 24/09/13 13:10:26
投稿者: chokobanana

Outlookの予定表をExcelを使って、削除、登録させるようにしたいです
 
下記コードは先日ネットで見つけたものです
対象予定表12か月分について
EntryIDが一致したときに更新
EntryIDがないときは登録
となっているかと思います。
 
こちらを、
EntryIDが一致したときに削除
EntryIDがないときは登録
とするにはどのようにしたらよろしいでしょうか。
https://ja.stackoverflow.com/questions/23493/outlook%e3%81%aevba%e3%81%a7%e4%ba%88%e5%ae%9a%e8%a1%a8%e5%89%8a%e9%99%a4%e3%81%8c%e3%81%95%e3%82%8c%e3%81%aa%e3%81%84#:~:text=Outlook%E3%81%AE
↑こちらを参考に何度か試してみましたが上手くいきません
 
よろしくお願いします
 
 
[Sub 参考()
 
    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Folder
    Dim olConItems As Outlook.Items
    Dim olItem As AppointmentItem
    Dim olItemBefor As AppointmentItem
    Dim checkFlg As Long
     
    '重複チェックフラグ初期値設定
    checkFlg = 0
 
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim lnContactCount As Long
    Dim i As Long
     
    '抽出期間の定義
    Dim strStart As String
    Dim strEnd As String
    Dim intKikan As Integer
     
     
    '対象予定表の抽出期間を月単位で指定します。
    '※抽出期間が短いと予定アイテムのチェックができず登録できない場合がありますので注意してください。
    intKikan = 12 '抽出期間を12か月にしています。
     
    strStart = Format(DateAdd("m", -intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
    strEnd = Format(DateAdd("m", intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの終了日を指定
     
     
    'スクリーンの更新は行われません。
    Application.ScreenUpdating = False
     
    'Excelのブックとワークシートのオブジェクトを設定します。
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
     
    wsSheet.Activate
     
    'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olConItems = olFolder.Items
 
    'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込む
    Set olConItems = olConItems.Restrict("[Start] >= '" & strStart & "' And [End] < '" & strEnd & "'")
 
 
    '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
    lnContactCount = 2
 
    Dim rc As Integer
    rc = MsgBox("予定表へ登録しますか?", vbYesNo + vbQuestion, "確認")
     
    If rc = vbYes Then
     
        '予定表一覧の件数分繰り返す。
        For i = lnContactCount To Cells(1, 1).End(xlDown).Row
            Set olItem = olApp.CreateItem(olAppointmentItem)
 
            '重複チェック&更新処理
            For Each olItemBefor In olConItems
                If TypeName(olItemBefor) = "AppointmentItem" Then
                 
                    'ExcelI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新
                    If olItemBefor.EntryID = Cells(i, 9) Then
                     
                        '比較用に一時的に作成
                        With olItem
                            .Subject = Cells(i, 1)
                            .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                            .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                        End With
     
                     
                        '重複フラグ1をセット
                         checkFlg = 1
                     
                        '登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
                        '※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
                        If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
     
     
                        Else
 
                            '定期アイテムは除外します。
                            If Not olItemBefor.IsRecurring Then
                                 With olItemBefor
                                    .Subject = Cells(i, 1)
                                    .Location = Cells(i, 2)
                                    .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                                    .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                                    .Body = Cells(i, 5)
                                    .RequiredAttendees = Cells(i, 6)
                                    .OptionalAttendees = Cells(i, 7)
                                    .Save
                                End With
                            End If
                        End If
                         
                        'Null out the variables.
                        Set olItem = Nothing
                         
                    End If
                End If
            Next
            'EntryIDが空である場合のみ新規登録をすることにしました。
            If checkFlg <> 1 And Cells(i, 9) = "" Then
                With olItem
                    .Subject = Cells(i, 1)
                    .Location = Cells(i, 2)
                    .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                    .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                    .Body = Cells(i, 5)
                    .RequiredAttendees = Cells(i, 6)
                    .OptionalAttendees = Cells(i, 7)
                    .Save
               End With
     
               'ExcelI列へ発行されたEntryIDを書き込み
               Cells(i, 9) = olItem.EntryID
                 
            End If
     
         
        '重複フラグリセット
        checkFlg = 0
     
    Next
     
    Else
        MsgBox "処理を中断します"
        Exit Sub
    End If
     
    'Null out the variables.
    Set olItem = Nothing
    Set olApp = Nothing
    Set wbBook = Nothing
    Set wsSheet = Nothing
    Set olNamespace = Nothing
    Set olFolder = Nothing
    Set olConItems = Nothing
 
             
    'Turn screen updating back on.
    Application.ScreenUpdating = True
     
    MsgBox "Outlook予定表の登録が完了しました!", vbInformation
     
End Sub][/code]

回答
投稿日時: 24/09/13 19:46:08
投稿者: simple

予定を管理するAppointmentItem オブジェクトのヘルプは下記のようです。
https://learn.microsoft.com/ja-jp/office/vba/api/outlook.appointmentitem
これには、削除するための Deleteメソッドが用意されていますので、
これを利用したらいかがですか?
 
# 私はこれ以上の情報を持ち合わせませんので、以上とさせていただきます。

回答
投稿日時: 24/09/14 12:30:08
投稿者: Suzu

引用:
下記コードは先日ネットで見つけたものです

引用:
↑こちらを参考に何度か試してみましたが上手くいきません

 
参考のコードを探し それを元に希望のコードに改造は よくありますが
それは、コードの内容をある程度理解して が前提。
 
コードがどんな条件でどんな動作を行っているかは把握していますか?
それが判らなければ、どこでどんな動作をさせれば良いか組み立てる事ができません。
 
どんな事を行い、どうなっって、希望の動作と違うのでしょうか。

投稿日時: 24/09/17 09:57:24
投稿者: chokobanana

(追記)
>コードがどんな条件でどんな動作を行っているかは把握していますか?
Suzu様の求めるレベルではないかもしれませんが
 
前後12か月について
EntryIDがある場合→EntryIDが一致したら更新
EntryIDがない場合→新規追加
となっているかと思います
 

引用:
If olItemBefor.EntryID = Cells(i, 9) Then
     olItemBefor.Delete

EntryIDが一致したら削除↑
これで削除はできたのですが
 
引用:
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
  
               Else
                  With olItemBefor
                       .Subject = Cells(i, 1)
                       .Location = Cells(i, 2)
                       .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                       .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                       .Body = Cells(i, 5)
                       .RequiredAttendees = Cells(i, 6)
                       .OptionalAttendees = Cells(i, 7)
                       .Save
                   End With
       End If

↑これを削除すると
sheetにある情報すべて(抽出期間外も)削除、追加となってしまいました
ここが更新となっているんではないかと思っております
見当違いだったらすいません
 
これを抽出期間のみに作用させるにはどうしたらいいのですか
 

回答
投稿日時: 24/09/18 08:34:43
投稿者: simple

技術的観点から、Microsoftのヘルプを紹介しましたが、別の観点から。
 
予定表は、期間が過ぎてもヒストリーとして残すことが多く、
保持していても害を及ぼすことは少ないものと思います。
ですから、IDを指定してまで削除する必要はなく、
普通は、一定期間(数年)が過ぎた段階で予定表を消すことが多いと思います。
このように頻度も低い訳ですから、手動で削除実行することを推奨します。
 
引用されたコードの出所も明記すべきです。
https://extan.jp/?p=1693#google_vignette
でしょうけど、そこで削除を扱っていないのも、そうした理由があるものと思料します。
 
【手動削除の方法】
・「表示」ー「ビューの変更」で「一覧」にすれば表形式の表示になります。
・削除したいところを、ShiftキーやCtrlキーを併用しながら選択し
  (Excelのシートとほぼ同等の操作です)
削除すればよいのではないですか?
 
手動のほうが自覚的な操作ですから、誤操作によるリスクも低く、
手間もかからず、確実なはずです。
あえてマクロで削除する必要もないと思います。
-----
ちなみに、
> sheetにある情報すべて(抽出期間外も)削除、追加となってしまいました
とのことですが、抽出対象を絞り込んでいるのは、

Set olConItems = olConItems.Restrict("[Start] >= '" & strStart & "' And [End] < '" & strEnd & "'")
ですから、そこが適切に動作していないものと推定します。
絞り込みできているのに、それ以外の期間のものまで削除することは考えにくいです。
ステップ実行して、olConItemsが適切なものになっているかをローカルウインドウで確認すべきです。
 
想定外のことがどうしても発生してしまう、ということなら、ますます手動で十分じゃないですか?
 
-----
ちなみに*2、 いったん削除したものも「削除済みアイテム」フォルダから戻すことが可能です。
(一定時間後に自動消去する「自動整理」を設定していれば別ですが。)

投稿日時: 24/09/18 09:11:45
投稿者: chokobanana

 simple 様
 
見たネットはどこかわからなくなったのでリンク先をのせられませんでした
私の見たものとは違うけどこちらにもあったのですね
 
しかも色々とあるので拝見させてもらいます
 
予定表が度々変更があるのと
変更箇所が多数、何台もPCがあるので手動だと時間を要してしまいます
また、間違うこともあったりで
 
簡便的に正確に変更方法を模索してマクロにいきつきました
 
 simple様せっかく色々と教えていただきましたが
マクロでできればと思っております
ごめんなさい
 
あまりマクロ詳しくないので初歩的な質問だったりするかもしれませんが
もし分かりましたら教えてください
 
よろしくお願いいたします。
 
ステップ実行でsimple様が指摘の箇所が黄色くなるのですが
ここからどうしていいのか分かりません
 
 
 
 
 
 

回答
投稿日時: 24/09/18 12:48:12
投稿者: Suzu

引用:
前後12か月について
EntryIDがある場合→EntryIDが一致したら更新
EntryIDがない場合→新規追加
となっているかと思います

 
質問の仕方が悪かったです。
そういう事をお聞きしたかったのではなく
どんな条件の時に、コードが実行されているのかを理解されていますか?
とお聞きしたかったのです。
 
そのうえで、上記の返答を見る限り、コードの認識に 間違いがあります。
以下に一部赤でコメントと、コードを追加しました。
 
'ExcelI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新
If olItemBefor.EntryID = Cells(i, 9) Then
 
'EntryIDと登録されているEntryIDが一致している時
  '比較用に一時的に作成
  With olItem
    .Subject = Cells(i, 1)
    .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
    .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
  End With
  '重複フラグ1をセット
  checkFlg = 1
  '登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
  '※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
 
  If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
 
  Else
  'ここでは、
    'EntryIDと登録されているEntryIDが一致している時
    'かつ
    'Subject、Start、End が一致していない
    'モノに対し アイテムを生成保存しています。
    'ここでの生成対象は、Start/End は、先の
    'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込む
    'Set olConItems = olConItems.Restrict("[Start] >= '" & strStart & "' And [End] < '" & strEnd & "'")
  'にて、指定したStart/End は 何ら反映されず、
     'Excel シート上のEntryIDが一致しているモノに、データを上書きしており
    'ご希望の指定期間の判定を行うなら、
    'strStart と、strEnd それぞれに対し シート3列目、4列目 のデータと比較し
    'データを生成するか決める必要があります。

    '定期アイテムは除外します。
    If Not olItemBefor.IsRecurring Then
      With olItemBefor
        .Subject = Cells(i, 1)
        .Location = Cells(i, 2)
        .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
        .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
        .Body = Cells(i, 5)
        .RequiredAttendees = Cells(i, 6)
        .OptionalAttendees = Cells(i, 7)
        .Save
      End With
    End If
  End If
  'Null out the variables.
  Set olItem = Nothing
 
Else
'EntryIDと登録されているEntryIDが一致していない時

 
End If
 
一致しない場合の動作については、何も指定されていません。
期間についても、上記内に記載した内容にて判定を行う必要があります。
 
それらを踏まえ、どの位置にてどんな判定を行えば 希望の条件が得られるか
を検討し、そこに、目的の動作を行う命令を入れるようにしましょう。

回答
投稿日時: 24/09/19 01:28:47
投稿者: MMYS

直接の回答ではありません。直接の原因は、他の方の回答を参考にしてください
 
提示されたコード。このコードはプロシージャひとつすべてを詰め込んでいます。
これでは、可読性が下がり、デバックが困難になり、原因追及も困難になります。
 
ひとつに詰め込んでいるため
・156行。
・1行の長さが最大145桁
・インデントが深い。最大10
・変数 15個
これでは、可読性か大幅に下がり、原因追及・デバックは困難ではありませんか
 
プログラムの原則に『単一責任の原則』があります。ここでの意味はプロシージャは一つの責任だけを持つ。となります。プロシージャは複数の役割は与えず、単一機能のみ。一つの仕事だけにする。という意味です。
 
今回のケース。要求から考えられる仕様は
・ユーザーへ確認
・指定IDの有無チェック
・指定IDを削除
・指定IDの登録
・指定IDの更新
と行ったところでしょうか。
 
たとえば、下記の行、コードとしては正しいのでしょうが、内容をすぐに理解出来るのでしょうか。
そして、実際のデバック時、条件が3つあり、ネストも非常に深く、このコードでデバック時にバグを見つけ出せるのでしょうか。

                        If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then

                        Else
                            '定期アイテムは除外します。
                            '<略>
                        End If

 
ここの処理ですが、もし、こんな都合のよい関数があったらどうでしょう。
・条件1 Subject が一致していること。
・条件2 Start が一致していること。
・条件3 End が一致していること。
すへての条件が揃った場合、Trueを返す。それ以外はFalseを返す。
 
では、上記の内容を満たすコードを作成してみましょう。コードは下記になります。
 
Function CheckMailItem(olItemBefor As AppointmentItem, olItem As AppointmentItem)
    Dim b As Boolean
    b = True
    b = b And (olItemBefor.Subject = olItem.Subject)
    b = b And (olItemBefor.Start = olItem.Start)
    b = b And (olItemBefor.End = olItem.End)
    CheckMailItem = b
End Function

上記コードは、すべての条件が、揃った場合、Trueを返します。条件が一つでも当てはまらない場合、Falseを返します。デバック時は、ステップ実行で、bの値を1行ごとに確認してください。条件不一致のとき、変数 b はFalseになり、その後の条件は関係なく 常にFalseです。つまり、すべての条件が Trueの時だけ Tureを返します。
※上記コードは論理演算の理解が必要ですが、本題から逸れるので割愛。
 
さて、最初のコードを次のように書き換えて、「ユーザーインターフェース」と「実行部」を分割。
    Dim b As Boolean
    b = CheckMailItem(olItemBefor, olItem)
    If b Then
        Debug.Print "条件OK", olItemBefor.Subject
    Else
        Debug.Print "定期アイテムは除外", olItemBefor.Subject
    End If

この時点では、まだ削除コードは書いてはいけません。この時点はイミテーションウインドウで正しく動作か確認します。正しいことが確認出来たら、今度は削除するプロシージャを作成します。
 
Sub DeleteMailItem(olItemBefor As AppointmentItem, i As Long)
    '定期アイテムは除外します。
    If Not olItemBefor.IsRecurring Then
         With olItemBefor
            .Subject = Cells(i, 1)
            .Location = Cells(i, 2)
            .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
            .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
            .Body = Cells(i, 5)
            .RequiredAttendees = Cells(i, 6)
            .OptionalAttendees = Cells(i, 7)
            .Save
        End With
    End If
End Sub

では、このプロシージャを呼び出して、削除コードを追加します。
 
    Dim b As Boolean
    b = CheckMailItem(olItemBefor, olItem)
    If b Then
        Debug.Print "条件OK", olItemBefor.Subject
    Else
        Debug.Print "定期アイテムは除外", olItemBefor.Subject
        DeleteMailItem olItemBefor, i
    End If

 
あとは、同じようにして、下記も書き換えて行きます。
 
変更前
    Dim rc As Integer
    rc = MsgBox("予定表へ登録しますか?", vbYesNo + vbQuestion, "確認")

    If rc = vbYes Then

       '予定表一覧の件数分繰り返す。
        For i = lnContactCount To Cells(1, 1).End(xlDown).Row
            Set olItem = olApp.CreateItem(olAppointmentItem)
            ' <以下略>

変更後
    Dim rc As Integer
    rc = MsgBox("予定表へ登録しますか?", vbYesNo + vbQuestion, "確認")

    If rc = vbYes Then
        UpdateOutlookPlan 引数
    End If

Sub UpdateOutlookPlan(引数)

    '予定表一覧の件数分繰り返す。
    For i = lnContactCount To Cells(1, 1).End(xlDown).Row
        Set olItem = olApp.CreateItem(olAppointmentItem)
        ' <以下略>
End Sub

 
以上のように、プロシージャを分割。プロシージャ単位でデバックし、単体でバグがないことを確認。今回は割愛してますが通常単体テストのコードを作成し、プロシージャ単体でしっかりテスト。品質が確保されたら、次の工程に進みます。次の工程でバグがある場合、
・呼び出し元のバグ
・呼び出し先のバグ。
のどちらかに切り分けます。呼び出し先なら、再度プロシージャ単体テスト。呼び出し元なら引数の値の確認。
 
一つのプロシージャで多くのことを行うと、バグの発生確率が上がり、デバックも困難になります。
プロシージャ自体の行数が短かいほど、バグの可能性が低く、仕様変更に強いプログラムになります。
 
 
※提示コードは、考え方の提示のため、動作検証はしておりません。

投稿日時: 24/09/19 09:36:27
投稿者: chokobanana

Suzu 様
 
質問を勘違いしまして、すいません
コードも理解できてませんでした
丁寧に説明していただきありがとうございます
 
 >'strStart と、strEnd それぞれに対し シート3列目、4列目 のデータと比較し
 >'データを生成するか決める必要があります。
 
分からないので教えてもらいたいのですが
下記コード↓の部分を「Subject、Start、End が一致していない」を削除して
「strStart と、strEnd それぞれに対し シート3列目、4列目 のデータと比較」一致したら
と修正したらよいのでしょうか。
 
また「strStart と、strEnd それぞれに対し シート3列目、4列目 のデータと比較」というのは
「EntryIDと登録されているEntryIDが一致」と同じように作成したら大丈夫ということでしょうか
 
 

引用:
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then

回答
投稿日時: 24/09/19 10:50:36
投稿者: Suzu

前提条件として

引用:
EntryIDが一致したときに削除
EntryIDがないときは登録

がありました。
 
加えて
引用:
 sheetにある情報すべて(抽出期間外も)削除、追加となってしまいました

 
から察するに
 
 
シート9列目 と 同一な EntryID の Outlookのアイテムがある場合
   → 削除
 
シート9列目 と 同一な EntryID の Outlookのアイテムがない場合
 かつ
シートの 3列目(開始)、4列目(終了) が指定した期間内 の場合
   → 登録
 
という事なのでは?
 
プログラミングは VBAに限らず
  条件 をきちんとご自身で理解しコード上で実現できる ができないといけません。
それは、VBAのコーディング うんぬん ではありません。読み解くのも同様です。
 
 
現状のコードを利用するなら、どんな条件の時に 動作するのかを理解する
 
イチから作るのであれば
 どういう条件の時に どういう動作をさせたい。
 を日本語できちんとまとめましょう。
  ご自身がフロー図の方が判り良いならフロー図で表現しても良いでしょう
 
今回、部分的に
  ○○の様な動作させたい場合の コードは何でしょうか?
 の様な質問があれば △△.Delete ですね 等、回答する事はありますが
 
当方から、条件分岐から動作まで含め こうしたら良いと言うコードを示す事はしません。

投稿日時: 24/09/20 13:35:32
投稿者: chokobanana

MMYS 様
 
全部はまだ理解できていませんが
ひとつひとつ作ってみようと思います
 
また分からないことがあったら教えてください
ありがとうございました