差出人の名前を変更して送信するマクロ

コメントにて以下のご要望をいただきました。


いつも頼りにさせていただいています。

Outlook2010ですが、海外の人向けにメールを送る際に、差出人の名前を英語に変更したい(日本に送る際は日本語で)とおもい、ItemSendで変更しようと思ったのですが読み取り専用ばかりで、良いプロパティが見つかりません。

アドバイス頂けると助かります。


差出人を変更したい場合、MailItem オブジェクトの SentOnBehalfOfName プロパティで変更が可能です。
ただし、このプロパティの名前からすると差出人の名前だけ変更するようなイメージになるのですが、実際には名前だけを指定するとその名前でアドレス帳を検索し、名前解決されたユーザーとして送信しようとします。
そのため、自分自身のアドレスで名前だけ変えたい場合は、名前の後に “<SMTP アドレス>” という文字を追加する必要があります。
また、このプロパティで差出人の名前を変えられるのは POP や IMAP といったインターネットのアカウントを使用している場合のみです。
Exchange サーバー環境や Outlook.com では差出人の名前はサーバー上の情報をもとに設定され、クライアント側で指定された名前が無視されるためです。
ItemSend で変更したいとのことだったのですが、どのような基準で日本語と英語を使い分けるのかがちょっと不明だったので、差出人を変更して送信するマクロとしました。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub SendUsingAlternativeName()
     ' 変更後の名前を指定
     Const ALT_NAME = "Test User"
     '
     Dim objMail As MailItem
     ' 表示しているメールを取得
     Set objMail = ActiveInspector.CurrentItem
     ' 差出人を指定
     objMail.SentOnBehalfOfName = ALT_NAME & " <" & _
         Session.CurrentUser.Address & ">"
     ' メールを送信
     objMail.Send
End Sub

マクロの登録方法やメニューへの追加について

広告

指定した分類項目のアイテムのアラームを解除するマクロ

コメントにて以下のご要望をいただきました。


お世話になっております。

指定の分類項目だけアラーム解除されるマクロを教えていただきたいです。


特定のフォルダー内のアイテムで指定された分類項目のアイテムを検索するには Items オブジェクトの Find メソッドが使用できます。
Find メソッドで条件を指定して検索を実行すると見つかったアイテムが返りますが、次のアイテムを検索するには FindNext を呼び出します。
そして、FindNext が Nothing を返すまで繰り返し呼び出すことで、検索条件に一致するアイテムをすべて取得することが可能です。
アラームの設定は ReminderSet プロパティにより行い、ReminderSet を False とするとアラームが解除できます。
現在表示しているフォルダー内の特定の分類項目を持つアイテムのアラームを解除するマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ClearAlarmForACategory()
     ' 検索する分類項目を指定
     Const CLEAR_CATEGORY = "テスト"
     '
     Dim fldCurrent As Folder
     Dim colItems As Items
     Dim objItem As MailItem
     ' 現在表示中のフォルダーを取得
     Set fldCurrent = ActiveExplorer.CurrentFolder
     ' フォルダーのアイテム一覧を取得
     Set colItems = fldCurrent.Items
     ' 指定された分類項目のアイテムを検索
     Set objItem = colItems.Find("[分類項目]='" & CLEAR_CATEGORY & "'")
     ' アイテムが見つからなくなるまで繰り返す
     While Not objItem Is Nothing
         ' アラームが設定されていたら解除
         If objItem.ReminderSet Then
             objItem.ReminderSet = False
             objItem.Save
         End If
         ' 次のアイテムを検索
         Set objItem = colItems.FindNext
     Wend
End Sub

マクロの登録方法やメニューへの追加について

Outlook 2016/2013/2010 のセキュリティ修正プログラム 2018 年 10 月分がリリース

10/10 に Outlook 2016、Outlook 2013 および Outlook 2010 のセキュリティ修正プログラムがリリースされました。
以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

Outlook 2016 のセキュリティ更新プログラムについて2018 年 10 月 10 日
1 件のセキュリティ修正と 10 件のセキュリティ以外の修正が行われています。

Word 2016 の修正

Word 2016 のセキュリティ更新プログラムについて: 2018 年 10 月 10 日
1 件の Outlook に関するセキュリティ以外の修正が行われています。

Office 2016 の修正

2018 年 10 月 2日更新プログラム Office 2016 (KB4461442)
こちらは 10/2 にリリースされたものですが、1 件の Outlook に関する不具合の修正が行われています。

Office 2013

Outlook 2013 の修正

Outlook 2013 のセキュリティ更新プログラムについて2018 年 10 月 10 日
1 件のセキュリティ修正と 2 件のセキュリティ以外の修正が行われています。

Office 2010

Outlook 2010 の修正

Outlook 2010 のセキュリティ更新プログラムについて2018 年 10 月 10 日
1 件のセキュリティ修正が行われています。

共有メールボックスの受信トレイのメールを Excel ファイルにエクスポートするマクロ

コメントにて以下のご要望をいただきました。


共有メールフォルダに受信したメールをエクセルに書き出したい

outlookで個人アドレスの他に2つの共有アドレスを
使用しておりそれぞれのShared Mailboxに受信したメールをいちいち検索しなければいけない業務があります。
  個人の受信フォルダーにあるメールのエクセルへの
書き出しマクロは見かけるのですが共有フォルダのものは見つけられません、
またそれらを参考に自作を試みたもののシステムエラー続きでお手上げです。
  受信時間、送信者、件名、本文(全文は不要)をエクセルに書き出すマクロを教えてください。


共有メールボックスの受信トレイを取得するには NameSpace オブジェクトの GetSharedDefaultFolder メソッドを使用します。
このメソッドで取得した Folder オブジェクトの Items に含まれるすべてのアイテムについて Excel ファイルへ受信日時などをエクスポートすればご要望は満たせるでしょう。

マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub ExportInboxInSharedMailboxToExcel()
     ' 共有メールボックスのメールアドレスを指定
     Const SHARED_MAILBOX = "shared1@example.com"
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\sharedmail.xlsx"
     ' Excel ファイルに書き出す本文の最大文字数
     Const MAX_BODY_CHARS = 250
     '
     Dim recOther As Recipient
     Dim fldOtherInbox As Folder
     Dim objBook
     Dim objSheet
     Dim objItem 'As MailItem
     Dim r As Integer
     ' 共有メールボックスの受信トレイを開く
     Set recOther = Session.CreateRecipient(SHARED_MAILBOX)
     Set fldOtherInbox = Session.GetSharedDefaultFolder(recOther, olFolderInbox)
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.windows(1).Activate
     Set objSheet = objBook.sheets(1)
     ' 1 行目はタイトルとして使用し、2 行目からデータ
     r = 2
     ' データがない行まで移動
     While objSheet.Cells(r, 1) <> ""
         r = r + 1
     Wend
     ' 共有メールボックスの受信トレイのすべてのアイテムについて処理
     For Each objItem In fldOtherInbox.Items
         ' メールの情報を Excel ファイルに追記
         With objSheet
             .Cells(r, 1) = objItem.ReceivedTime
             ' 差出人の名前にアドレスが含まれない場合のみアドレスを追加
             If InStr(objItem.SenderName, objItem.SenderEmailAddress) = 0 Then
                 .Cells(r, 2) = objItem.SenderName & _
                     " <" & objItem.SenderEmailAddress & ">"
             Else
                 .Cells(r, 2) = objItem.SenderName
             End If
             .Cells(r, 3) = objItem.Subject
             .Cells(r, 4) = Left(objItem.Body, MAX_BODY_CHARS)
         End With
         r = r + 1
     Next
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

マクロの登録方法やメニューへの追加について

Outlook 2019 の新機能

9/25 に Office 2019 が一般向けにリリースされ、10/5ました。

Office 2019 に含まれる Outlook 2019 の主な新機能としては以下のようなものがあります。

  • 優先受信トレイ
  • スケーラブル ベクター グラフィックス
  • ハンズフリー入力
  • 3 つ目のタイムゾーンの追加
  • メールの読み上げ
  • クラウド添付ファイルの自動ダウンロード

ただ、現在 Outlook 2016 を使われている方の中には、既に上記の機能を使っている、という人もいるかもしれません。
というのも、Office 2019 はこれまでの Office のバージョン アップとはちょっと異なるからです。

Office 2013 までは、Office のメジャー バージョン アップが 3-4 年に1度の割合で行われ、UI の変更や大掛かりな新機能の追加はメジャー バージョン アップで行われていました。

しかし、Office 2016 では、従来のインストール方式である MSI 版はこれまでと同じ方式 (機能追加なし) である一方、新しい C2R (Click-To-Run) 版では随時新機能が追加されるようになりました。
これは、日々新機能が追加されるクラウドやモバイルのスピード感に対応するための提供方法と思われます。
こうなってくると、メジャー バージョン アップはもはや不要と思われるのですが、問題は MSI 版を使用しているユーザーです。

MSI 版は C2R 版のように新機能が追加されないので、Office の進化に取り残されて行ってしまいます。
そこで、こうした MSI 版を使用しているユーザー向けに最新の Office 2016 の C2R 版を「Office 2019」として提供するというのが、今回のバージョン アップになります。
そのため、Office 2019 という名前ではありますが、ファイルのバージョン番号は 2016 と同じ 16.0 となっています。

Office 2016 の C2R 版の最新を切り出した形でリリースされているため、Office 2019 は C2R 版しか存在しないことになりますが、だからと言って今後 Office の C2R 版の一本化がされるというわけでもなさそうです。
というのも、もともと MSI 版を使用しているユーザーは新機能より安定性を求めており、UI の変更なども極力望んでいないと想定されるからです。
したがって、Office 2019 はリリース後は新機能の追加が凍結され、セキュリティ修正や重要な修正だけが行われるようなものになるでしょう。

メール送信時に配布グループを展開してアドレスを確認し、社外のアドレスへの送信で警告を表示するマクロ

コメントにて以下のご要望をいただきました。


はじめまして。
初心者ゆえ色々と参考にさせて頂き助かっております。
単純な質問で申し訳ありません。
Exchange環境でOutlook2016でメール送信時にメーリングリスト(グローバル配布先グループ)の
メンバーのSMTPアドレスを展開してメッセージ表示させるようにしたいのですが、
どうすれば良いのでしょうか。
グローバルの配布先グループに社外アドレスが含まれているものもあり、警告を出したいと
考えています。
ご教授のほど、宜しくお願い致します。


Exchange の配布グループについては Recipient オブジェクトの AddressEntry プロパティの GetExchangeDistributionList メソッドで ExchangeDistributionList オブジェクトとして取得可能です。
また、グループのメンバーは  ExchangeDistributionList オブジェクトの GetExchangeDistributionListMembers メソッドで AddressEntries として取得可能です。
これらのオブジェクトを使用してメンバーを展開することができます。
また、以前 Outlook の連絡先グループを展開するマクロについても「連絡先グループのメンバーを展開してメールアドレスを取得するマクロ」として作成していましたので、こちらの機能も追加しました。

マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。

'
Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
Const REC_DELIMITER = "; " ' 複数受信者を表示する際の区切り文字
'
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Dim objRec As Recipient
     Dim strSMTPAddr As String
     Dim strOut As String
     Dim iRet As Integer
     ' 組織外の受信者が存在するかどうかの確認
     bExternal = False
     strOut = ""
     For Each objRec In Item.Recipients
         ' 受信者の種類で判断
         Select Case objRec.AddressEntry.AddressEntryUserType
             Case olExchangeDistributionListAddressEntry
                 ' Exchange の配布グループの展開
                 ExpandExDistList objRec.AddressEntry, strOut
             Case olOutlookDistributionListAddressEntry
                 ' Outlook の連絡先グループの展開
                 ExpandOlContactGroup objRec, strOut
             Case Else
                 ' グループではない受信者
                 strSMTPAddr = GetSMTPAddr(objRec.AddressEntry)
                 If Not strSMTPAddr Like MY_DOMAIN Then
                     strOut = strOut & strSMTPAddr & REC_DELIMITER
                 End If
         End Select
     Next
     ' 組織外の受信者が含まれていた場合の処理
     If strOut <> "" Then
         iRet = MsgBox("あて先に組織外のドメインのメールアドレスが含まれています。送信しますか?" & _
             vbCrLf & "外部ドメイン宛: " & strOut, vbYesNo, "送信確認")
         Select Case iRet
             Case vbYes
                 ' 送信日時を 1 分後に設定
                 Item.DeferredDeliveryTime = DateAdd("n", 1, Now)
                 Cancel = False ' 念のため
             Case vbNo
                 Cancel = True
         End Select
     End If
End Sub
' SMTP アドレス取得関数
Private Function GetSMTPAddr(objAddrEntry As AddressEntry)
     Const PR_ORIGINAL_DISPLAY_NAME = "http:" & "//schemas.microsoft.com/mapi/proptag/0x3a13001e"
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
     Dim strSMTPAddr As String
     If objAddrEntry.Type = "SMTP" Then
         strSMTPAddr = objAddrEntry.Address
     Else ' Exchange 対応
         If objAddrEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
             strSMTPAddr = objAddrEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
         Else
             strSMTPAddr = objAddrEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
         End If
     End If
     GetSMTPAddr = strSMTPAddr
End Function
' Exchange 配布グループを展開するサブ プロシージャ
Private Sub ExpandExDistList(objExchDL As AddressEntry, ByRef strOut As String, Optional ByVal strExpanded As String = "")
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
     Dim objExDistList As ExchangeDistributionList
     Dim colMembers As AddressEntries
     Dim objMember As AddressEntry
     Dim strSMTPAddr As String
     '
     If InStr(strExpanded, objExchDL.ID & ";") > 0 Then
         Exit Sub    ' 展開済みのグループは展開しない
     End If
     strExpanded = strExpanded & objExchDL.ID & ";"
     ' Exchange 配布グループ オブジェクトを取得
     Set objExDistList = objExchDL.GetExchangeDistributionList
     ' 配布グループのメンバーを取得
     Set colMembers = objExDistList.GetExchangeDistributionListMembers
     ' メンバーごとに処理
     For Each objMember In colMembers
         If objMember.AddressEntryUserType = olExchangeDistributionListAddressEntry Then
             ' メンバーが配布グループなら再帰して展開
             ExpandExDistList objMember, strOut, strExpanded
         Else
             ' メンバーの SMTP アドレスを取得
             strSMTPAddr = GetSMTPAddr(objMember)
             ' メンバーのアドレスが社外なら社外リストに追加
             If Not strSMTPAddr Like MY_DOMAIN Then
                 strOut = strOut & strSMTPAddr & REC_DELIMITER
             End If
         End If
     Next
End Sub
' Outlook の連絡先グループを展開するサブ プロシージャ
Private Sub ExpandOlContactGroup(objRec As Recipient, ByRef strOut As String, Optional ByVal strExpanded As String = "")
     Dim strCbLo As String
     Dim strCbHi As String
     Dim iCb As Integer
     Dim strEntryID As String
     Dim distList As DistListItem
     Dim objMember As Recipient
     Dim strSMTPAddr As String
     Dim i
     '
     If strExpanded = "" Then ' 展開済みのグループがない = トップのグループ
         ' 65 文字目からの 4 文字がエントリー ID の長さ
         strCbLo = Mid(objRec.AddressEntry.ID, 65, 2)
         strCbHi = Mid(objRec.AddressEntry.ID, 67, 2)
         iCb = Val("&H" & strCbHi & strCbLo)
         ' 73 文字目からがアイテムのエントリー ID
         strEntryID = Mid(objRec.AddressEntry.ID, 73, iCb * 2)
         Set distList = Session.GetItemFromID(strEntryID)
     Else ' 入れ子になっているグループの場合は 43 文字目からがアイテムのエントリー ID
         strEntryID = Mid(objRec.AddressEntry.ID, 43)
     End If
     '
     If InStr(strExpanded, strEntryID) > 0 Then
         Exit Sub      ' 展開済みのグループは展開しない
     End If
     strExpanded = strExpanded & strEntryID & ";"
     ' 連絡先グループ オブジェクトを取得
     Set distList = Session.GetItemFromID(strEntryID)
     ' メンバーごとに処理
     For i = 1 To distList.MemberCount
         Set objMember = distList.GetMember(i)
         If objMember.Address = "Unknown" Then
          ' メンバーが配布グループなら再帰して展開
             ExpandOlContactGroup objMember, strOut, strExpanded
         Else
             ' メンバーの SMTP アドレスを取得
             strSMTPAddr = GetSMTPAddr(objMember.AddressEntry)
             ' メンバーのアドレスが社外なら社外リストに追加
             If Not objMember.Address Like MY_DOMAIN Then
                 strOut = strOut & objMember.Address & REC_DELIMITER
             End If
         End If
     Next
End Sub

マクロの登録方法やメニューへの追加について

メールの本文で選択されたキーワードを指定したコードページでエンコードして Web で検索するマクロ

メールの本文で選択されたキーワードを Web で検索するマクロのコメントにて以下のご要望をいただきました。


上記マクロをカスタムしてみたいのですが、各検索の引数の値を文字コードを指定してURLエンコードしたいのですが可能でしょうか?


以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。

' コードページ変換の API を定義
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32.dll" ( _
     ByVal CodePage As Long, _
     ByVal dwFlags As Long, _
     ByVal lpWideCharStr As LongPtr, _
     ByVal cchWideChar As Long, _
     ByVal lpMultiByteStr As LongPtr, _
     ByVal cchMultiByte As Long, _
     ByVal lpDefaultChar As LongPtr, _
     ByVal lpUsedDefaultChar As Long) As Long
' コードページの定数
Private Const CP_UTF8 As Long = 65001
Private Const CP_SJIS As Long = 932
'
' UTF-8 で Google 検索を行うマクロ
Public Sub GoogleSearchUTF8()
     WebSearchWithCP "https://www.google.co.jp/search?q=", CP_UTF8
End Sub
' Shift-JIS で Google 検索を行うマクロ
Public Sub GoogleSearchSJIS()
     WebSearchWithCP "https://www.google.co.jp/search?q=", CP_SJIS
End Sub
' コードページ指定で検索を実行する共通マクロ
Private Sub WebSearchWithCP(strCmd As String, lCodePage As Long)
     Dim objDoc As Object ' Word.Document
     Dim strKey As String
     Dim objShell As Object
     Dim lBufSize As Long
     Dim abBuf() As Byte
     Dim i As Integer
     Dim strHex As String
     ' 選択された文字列を取得
     Set objDoc = ActiveInspector.WordEditor
     strKey = Trim(objDoc.Application.Selection.Text)
     ' 文字列を指定されたコードページに変換した際のバイト数を取得
     lBufSize = WideCharToMultiByte(lCodePage, 0, StrPtr(strKey), Len(strKey), 0, 0, 0, 0)
     ' 必要なサイズにバッファを設定
     ReDim abBuf(lBufSize)
     ' 文字列を指定されたコードページに変換
     WideCharToMultiByte lCodePage, 0, StrPtr(strKey), Len(strKey), VarPtr(abBuf(0)), lBufSize, 0, 0
     ' 変換されたバイト配列を %xx の形式に変換
     strKey = ""
     For i = 0 To lBufSize - 1
         strHex = Right("0" & Hex(abBuf(i)), 2)
         strKey = strKey & "%" & strHex
     Next
     ' 取得した文字列を引数に追加して実行
     Set objShell = CreateObject("WScript.Shell")
     objShell.Run strCmd & strKey
End Sub

マクロの登録方法やメニューへの追加について