Outlookメールで登録したグループ宛先をワンクリック入力｜VBAマクロ

Sub AddGroupMembersToMailRecipient()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim Item As Object
    Dim olGroup As Outlook.DistListItem
    Dim olMail As Outlook.MailItem
    Dim groupName As String
    Dim found As Boolean

    ' グループ名を設定（適切なグループ名を指定）
    groupName = "YourGroupName"  ' 例: "MarketingTeam" など

    ' Outlookオブジェクトの初期化
    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderContacts)
    found = False

    ' 連絡先フォルダーを検索してグループを探す
    For Each Item In olFolder.Items
        If TypeName(Item) = "DistListItem" Then
            Set olGroup = Item
            If olGroup.DLName = groupName Then
                found = True
                Exit For
            End If
        End If
    Next Item

    If found Then
        ' 選択されているメールアイテムを取得
        If TypeOf olApp.ActiveWindow Is Outlook.Inspector Then
            Set olMail = olApp.ActiveInspector.CurrentItem
        ElseIf TypeOf olApp.ActiveWindow Is Outlook.Explorer Then
            Set olMail = olApp.ActiveExplorer.Selection.Item(1)
        End If

        ' メールの宛先にグループメンバーを追加
        If Not olMail Is Nothing Then
            For i = 1 To olGroup.MemberCount
                olMail.Recipients.Add(olGroup.GetMember(i).Address)
            Next i
            olMail.Recipients.ResolveAll
            olMail.Save
        End If
    Else
        MsgBox "指定された連絡先グループが見つかりません。"
    End If

    ' オブジェクトの解放
    Set olMail = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub

groupName = "YourGroupName"

Set olMail = olApp.ActiveInspector.CurrentItem  Set olMail = olApp.ActiveExplorer.Selection.Item(1)

olMail.Recipients.Add(olGroup.GetMember(i).Address)

Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(olFolderContacts)

For Each Item In olFolder.Items
If TypeName(Item) = "DistListItem" Then
Set olGroup = Item
If olGroup.DLName = groupName Then
found = True
Exit For
End If
End If
Next Item

If TypeOf olApp.ActiveWindow Is Outlook.Inspector Then
Set olMail = olApp.ActiveInspector.CurrentItem
ElseIf TypeOf olApp.ActiveWindow Is Outlook.Explorer Then
Set olMail = olApp.ActiveExplorer.Selection.Item(1)
End If

If Not olMail Is Nothing Then
For i = 1 To olGroup.MemberCount
olMail.Recipients.Add(olGroup.GetMember(i).Address)
Next i
olMail.Recipients.ResolveAll
olMail.Save
End If

Set olMail = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing