[[20240129173258]]　『マクロでメールの宛先編集』（まくろくん）　ページの最後に飛ぶ

『マクロでメールの宛先編集』（まくろくん）

表題の件、教えてください。
マクロでOutlookメールの宛先を設定する際に、もし存在しないアドレスがいたら宛先から削除するやり方を探しています。
通常メールなら出来たのですが、同じ考え方で予定表の会議メールで宛先を設定しようとすると出来ません。分かる方がいらっしゃいましたらアドバイスお願いします。

＜通常メール：うまくいく＞
'Outlookメール作成

 Dim myOutlook As Object
 Dim mail As Object

 Set myOutlook = CreateObject("outlook.application")
 Set mail = myOutlook.CreateItem(0)

 With mail
    .To = Worksheets("Sheet1").Range("A1").Value
    .CC = Worksheets("Sheet1").Range("B1").Value
    .Recipients.ResolveAll  '宛先の名前の確定

     ' 存在しない宛先を除外
    For i = .Recipients.Count To 1 Step -1
        If Not .Recipients.Item(i).Resolved Then
            .Recipients.Remove i
        End If
    Next i
 End With

  mail.Display

＜予定表の会議メール：うまくいかない＞
下記の状態で流すと、何も宛先に貼り付かない。
”存在しない宛先を除外”部分の工程をコメントアウトすると、宛先は貼り付くが、存在しないアドレスも貼りついてしまう。

    Dim objApp As Object
    Dim objAppt As Object
    Dim objAttendee As Object

    Set objApp = CreateObject("Outlook.Application")
    Set objAppt = objApp.CreateItem(1)

    With objAppt
        .MeetingStatus = 1

        '参加者(必須)
        Set objAttendee = .Recipients.Add(設定ws.Range("AW4").Value)
        objAttendee.Type = 1

        '参加者(任意)
        Set objAttendee = .Recipients.Add(設定ws.Range("AX4").Value)
        objAttendee.Type = 2

        ' 宛先を確定（存在しない宛先を除外するために確定）
        .Recipients.ResolveAll

     ' 存在しない宛先を除外
       For i = .Recipients.Count To 1 Step -1
           If Not .Recipients.Item(i).Resolved Then
               .Recipients.Remove i
            End If
        Next i

        '表示
        .Display

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

Excel2019で確認したところ、そのままで正常に動作します。

他の部分に間違いがないか、設定に問題がないか、
Excelのバージョンによる違いに問題がないかなどを確認してください。

そのままでと書きましたが、以下は追加したかな。

    Dim i As Long
    Dim 設定ws As Worksheet: Set 設定ws = ActiveSheet

    End With

＞下記の状態で流すと、何も宛先に貼り付かない。
＞”存在しない宛先を除外”部分の工程をコメントアウトすると、宛先は貼り付＞くが、存在しないアドレスも貼りついてしまう。

明らかにおかしいですよね。
どのように動作しているかデバッグで追いかけてください。
（ゆたか） 2024/01/30(火) 11:41:51

ありがとうございます。
デバックしながら確認して一つ分かったことがあります。解決に至っていませんが、何か分かりましたらお願いいたします。

必須に5人いてそのうち1人宛先不能が混じっている。
objAttendeeに5人分のアドレス格納される。

        '参加者(必須)
        Set objAttendee = .Recipients.Add(設定ws.Range("AW4").Value)
        objAttendee.Type = 1

次に任意に3人いてそのうち2人宛先不能が混じっている。
objAttendeeに3人分のアドレス格納される
★必須と任意でobjAttendeeを使いまわしているため、必須に格納したのが書き換わってしまう？

        '参加者(任意)
        Set objAttendee = .Recipients.Add(設定ws.Range("AX4").Value)
        objAttendee.Type = 2

        ' 宛先を確定（存在しない宛先を除外するために確定）
        .Recipients.ResolveAll

下記でRecipients.Countに何が入るかデバックで見たところ、宛先（必須、任意）を色々変更しても、
いつも「2」が入る。そのためか？、宛先に全く何も入らない現象となる。

     ' 存在しない宛先を除外
       For i = .Recipients.Count To 1 Step -1
           If Not .Recipients.Item(i).Resolved Then
               .Recipients.Remove i
            End If
        Next i
（まくろくん） 2024/01/30(火) 13:50:18

AW4とAX4の値（データ構造）はどうなってるんでしょうかね？

わたしはそれぞれのセルに１つのメールアドレスが入っているのかと思っていましたが。

だから、カウントは当然ながら２です。

https://learn.microsoft.com/ja-jp/office/vba/api/outlook.recipients.add

ここを見ても、複数のレシピアントを一度に指定できるとはありませんが。

＞★必須と任意でobjAttendeeを使いまわしているため、必須に格納したのが書き換わってしまう？

その時点で正しいアドレスがセットされているので問題ないと思います。
まあ、使い回しはしないほうが良いでしょうけれど（書き換え後に前のものと勘違いするかも）

（ゆたか） 2024/01/30(火) 15:36:49

ありがとうございます。理解しました。
AW4とAX4セルですが、1つのセルにアドレスを複数繋げています。（〇〇@ne.jp;〇〇@ne.jp)
通常メールだとそれで複数アドレスの数と同じ数を下記コードでカウントしてくれるのですが、会議メールだと同じやり方していても「2」になってしまうので、何か方法はないかと探しておりました。

    For i = .Recipients.Count To 1 Step -1
        If Not .Recipients.Item(i).Resolved Then
            .Recipients.Remove i
        End If
    Next i
（まくろくん） 2024/01/30(火) 16:07:37

後学のため、改良版を作成してみました。ご参考まで。
なお、定数が数字の１とか２とかではわかりにくいのでライブラリを参照しています。

 Sub c()

    ' ツール＞参照設定でmicrosoft outlook xx.x object libraryをチェックしてね

    Dim i As Long
    Dim 設定ws As Worksheet: Set 設定ws = ActiveSheet
    Dim Recipients As Variant

    Dim objApp As Outlook.Application
    Dim objAppt As Outlook.AppointmentItem
    Dim objAttendee As Outlook.Recipient

    Set objApp = CreateObject("Outlook.Application")
    Set objAppt = objApp.CreateItem(olAppointmentItem)

    With objAppt

        .MeetingStatus = olMeeting ' AppointmentItemをMeetingItemにする

        Recipients = Split(設定ws.Range("AW4").Value, ";") '参加者(必須)
        For i = LBound(Recipients) To UBound(Recipients)
            Set objAttendee = .Recipients.Add(Recipients(i))
            objAttendee.Type = olRequired
        Next

        Recipients = Split(設定ws.Range("AX4").Value, ";") '参加者(任意)
        For i = LBound(Recipients) To UBound(Recipients)
            Set objAttendee = .Recipients.Add(Recipients(i))
            objAttendee.Type = olOptional
        Next

        .Recipients.ResolveAll 'すべての受信者オブジェクトを解決

        For i = .Recipients.Count To 1 Step -1 ' 解決しない宛先を削除
            If Not .Recipients.Item(i).Resolved Then .Recipients.Remove i
        Next i

        .Display '表示

    End With

 End Sub
（ゆたか） 2024/02/01(木) 09:28:51

コメント返信：

[ 一覧(最新更新順) ]

[[20240129173258]] 『マクロでメールの宛先編集』（まくろくん） ページの最後に飛ぶ

[[20240129173258]]　『マクロでメールの宛先編集』（まくろくん）　ページの最後に飛ぶ