メールの内容と To および Cc のアドレスを Excel ファイルに書き出すマクロ

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


初めまして。当然のご質問失礼いたします。
VBA初心者です。どうしてもわからず困っていることがありご質問させていただきました。

本サイトの下記を参考にメールをExcelへの書き出しを実施したいと考えております。

「メールの内容を Excel ファイルにかき出すマクロ」

しかし、受信者(To)のメールアドレスを取得したく、下記を記載しましたが
表示名が抽出されてしまうことがあり困っています。
メールアドレスをピンポイントで書き出す方法をご教示いただけないでしょうか?

.Cells(r, 1) = objItem.To

知識不足で申し訳ございませんが、ご回答いただけますと幸いです。
どうぞよろしくお願いいたします。


MailItem オブジェクトの ToCc には表示名のみが含まれており、受信者のアドレスを取得するには Recipients プロパティで取得できる Recipient オブジェクトの Address プロパティを使用します。
ただ、Recipients には To 受信者も Cc 受信者も含まれているので、Type プロパティで To か Cc かを判断する必要があります。
マクロは以下のようになりますなマクロで実現できます。

'
Public Sub ExportToExcelWithToCc()
     ' EXCEL ファイルをフルパスで指定
     Const EXCEL_FILE = "c:\temp\data.xlsx"
     Dim objItem As MailItem
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim objRec As Recipient
     Dim strName As String
     Dim strTo As String
     Dim strCc As String
     Dim r As Integer
     ' メールをどのように開いているか確認
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.Windows(1).Activate
     Set objSheet = objBook.Sheets(1)
     ' データがない行まで移動
     r = 2
     While objSheet.cells(r, 1) <> ""
         r = r + 1
     Wend
     ' アイテムの Recipients から To と Cc を生成
     strTo = ""
     strCc = ""
     For Each objRec In objItem.Recipients
         With objRec
             If .Address = .Name Then
                 strName = .Name
             Else
                 strName = .Name & "<" & .Address & ">"
             End If
             ' 受信者の種別が To かどうか判定
             If .Type = olTo Then
                 strTo = strTo & strName & ";"
             Else
                 strCc = strCc & strName & ";"
             End If
         End With
     Next
     ' 最後の余計な ; を削除
     If Len(strTo) > 0 Then
         strTo = Left(strTo, Len(strTo) - 1)
     End If
     If Len(strCc) > 0 Then
         strCc = Left(strCc, Len(strCc) - 1)
     End If
     ' メールの情報を Excel ファイルに追記
     With objSheet
         .cells(r, 1) = objItem.SenderEmailAddress
         .cells(r, 2) = objItem.Subject
         .cells(r, 3) = objItem.Body
         .cells(r, 4) = strTo
         .cells(r, 5) = strCc
     End With
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

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

他のユーザーの代理で会議出席依頼を送信するマクロ

Outlook でメールの代理送信を行う場合、送信前に SentOnBehalfOfName プロパティに名前とアドレスを追加するか、SendUsingAccount プロパティに差出人のアカウントを設定して送信することで実現できます。
しかし、会議出席依頼を代理で送信する場合にはこの方法は使用できません。
その理由は、会議出席依頼が元になる予定アイテムをベースとして生成されるためです。

会議出席依頼の送信者はその会議の開催者になりますが、会議出席依頼のもとになる予定アイテムは開催者の予定表に存在しなければなりません。
つまり、会議出席依頼の送信前に送信者の予定表に会議の予定アイテムを作成する必要があるのです。
そのため、会議出席依頼の代理送信を行うには以下の権限が必要となります。

  • 開催者の予定表への書き込み権限
  • 開催者の代理としてメールを送信する権限

そして、マクロで送信する場合の具体的な手順は以下のようになります。

  1. GetSharedDefaultFolder により代理送信をするユーザーの予定表フォルダーを開く
  2. 予定表フォルダーの Items の Add メソッドで会議となる予定アイテムを作成する
  3. 予定アイテムの件名や場所、出席者、開始日時、終了日時などを設定する
  4. 予定アイテムの MeetingStatus に olMeeting を指定し、Send メソッドで送信する

会議出席依頼を代理送信するマクロのサンプルは以下のようになります。

'
Public Sub SentMeetingRequestOnBehalf()
     Dim recOrganizer As Recipient
     Dim fldCalendar As Folder
     Dim apptMeeting As AppointmentItem
     Dim attRequired As Recipient
     Dim attOptional As Recipient
     ' 開催者のアドレスを指定して Recipient オブジェクトを作成
     Set recOrganizer = Session.CreateRecipient("organizer@example.com")
     recOrganizer.Resolve
     ' 開催者の予定表を取得
     Set fldCalendar = Session.GetSharedDefaultFolder(recOrganizer, olFolderCalendar)
     ' 予定表に予定アイテムを追加
     Set apptMeeting = fldCalendar.Items.Add
     '
     With apptMeeting
         ' 会議の件名や場所などを指定
         .Subject = "会議の件名"
         .Location = "会議の場所"
         .Start = "2021/4/24 10:00"
         .End = "2021/4/24 10:30"
         .Body = "会議の本文"
         ' 必須出席者の追加
         Set attRequired = .Recipients.Add("required@example.com")
         attRequired.Type = olRequired
         ' 任意出席者の追加
         Set attOptional = .Recipients.Add("optional@example.com")
         attOptional.Type = olOptional
         ' 予定アイテムを会議アイテムに変更
         .MeetingStatus = olMeeting
         ' 会議出席依頼を送信
         .Send
     End With
End Sub

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

オンラインモードとキャッシュ モード

Outlook で Exchange サーバーに接続する場合のモードとして、オンライン モードとキャッシュ モードがあります。
今回はそれぞれのモードの特徴について説明します。 

オンライン モード

まず、オンライン モードについてですが、実は Outlook のユーザー インターフェイス上に「オンライン モード」という記載はありません。
Exchange キャッシュ モードを使用するかどうかの設定があり、これがオフの状態を「オンライン モード」と呼んでいます。
このモードでは、メールのデータをローカルにキャッシュせず、常にサーバーからデータを取得して表示するので、サーバーがオンライン状態で接続できない場合には一切使用できなくなります。
 
もともと、初期の Outlook ではキャッシュ モードは存在せず、オンライン モードのみでした。
(ローカルにデータを同期して参照するオフライン モードというものがありましたが、ややこしくなるので今回は割愛します。)
Outlook の最初のバージョンがリリースされた当時、基本的には Exchange サーバーとの接続は組織内の LAN 接続で使用されていたので、オンライン モードではサーバーとの接続は高速で安定したものであることが前提となっています。
また、オンライン モードでアイテムを開いた場合、クライアント上で開いているアイテムのデータはサーバー上でも開かれ、ネットワークを通じてリンクした状態となっています。
そのため、以下のようなデメリットがあります。 

  • サーバーの応答がすぐに返ることが想定されており、サーバーからの応答が遅延するとパフォーマンスが低下する
  • ネットワークの切断などが発生すると、Outlook がハングアップしたり、作成中のメールの送信・保存ができなくなる場合がある
  • 同じアイテムを複数のクライアントで同時に編集すると、最初に保存を行ったクライアント以外では上書き保存ができなくなる

例えば、サーバーからの応答が返ってくるまでの時間が 200 ミリ秒を超えるような場合、スクロールやフォルダーの切り替えに時間がかかってストレスを感じるようになります。
これは、オンライン モードの通信が RPC という LAN 接続で使用されていたプロトコルをベースとしているためです。
RPC はサーバーの機能をネットワーク経由で関数呼び出しのように手軽に使用するというプロトコルですが、このプロトコルの制限としてリクエストと応答のパケットの最大サイズが 32K バイトまでというものがあります。
そのため、クライアントのリクエストとサーバーの応答の間に 200 ミリ秒の遅延がある場合、320K バイトのデータを受け取るには単純計算で (320K / 32K) * 200 = 2000 ミリ秒、つまり 2 秒かかることになります。
メッセージのダウンロードや一括コピーという処理では 32K のブロックをまとめて転送するというようなことも可能ですが、スクロールのような処理ではこの制限を受けるので、メッセージ数やメッセージに含まれる受信者の数などが多かった場合に遅延が積み重なって Outlook の動作が遅くなります。
 
このような場合に勘違いされやすいのが「インターネット接続の帯域幅には余裕があるので遅延が発生するはずがない」というものです。
どれだけ帯域幅を確保していたとしても、ルーターやファイアウォールの処理能力に問題があったり、サーバーまでの間でいくつものネットワーク機器を経由したりするような場合にはパケットの遅延が生じることがあります。
Outlook ではサーバーの応答を受け取るまでにかかった時間の統計を取っており、タスクバーの Outlook アイコンを CTRL キーを押しながら右クリックして [接続状態] をクリックすると表示される [Outlook の接続状態] ダイアログの [平均反応] でサーバーの応答の平均時間が確認できます。
この値はミリ秒単位となっていますので、これが 200 を超えるようであればオンライン モードには向かないということになります。
また、たとえ平均反応が 200 以下だったとしても、無線 LAN を使用していて Outlook の使用中にネットワークの切断が発生しやすかったり、Outlook を起動したまま PC をスリープモードにしたりというような使い方をしているのであれば、やはりオンライン モードで使用するべきではないでしょう。
 
セキュリティ上の理由でクライアントにデータを保持させることができないというような理由でオンライン モードが採用されることも多いようですが、たとえオンライン モードで使用していても添付ファイルを開いたりすると、そのファイルはローカルに一時的に保存されます。
メールから直接開いたり、添付ファイルのプレビューを行ったときにはローカルに保存されないと勘違いされることもありますが、このような操作でも一時的にローカルにファイルが保存され、そのファイルを関連付けられたアプリケーションで開くという動作になるのです。
そのため、セキュリティ上の理由でクライアントにデータを保持させたくないということなのであれば、オンライン モードを使うのではなく、Outlook on the Web を使用し、添付ファイルも Office Web Apps で開くということを徹底したほうが良いと考えられます。 

キャッシュ モード

  キャッシュ モードは Outlook 2003 以降で追加されたものであり、既定で有効となります。
このモードでは、サーバーのメールボックスの情報をローカルの OST ファイルに保存し、Outlook でアイテムの表示や編集を行う場合はローカルに格納された OST ファイルのデータを参照するという動作になります。
そのため、オンライン モードとは異なり、サーバーとの接続状況を気にせず使用することが可能です。
メールボックスとローカルの OST ファイルの同期は、定期的にサーバーからデータを取得するというようなものではなく、サーバーから変更の通知を受け取ったり、OST ファイルのアイテムを更新したりすると自動的に同期が行われるので、ほぼリアルタイムでの同期が可能です。
「ほぼリアルタイム」というのは変更が通知されてから実際に同期するまでに同期タイマーという機能でタイムラグが発生するためです。
例えば、サーバーからの変更通知を受信すると、Outlook は既定で 5 秒待って同期を開始します。
そして、待機中に新たな通知を受信すると、そこからさらに 5 秒待つ動作となります。
頻繁に通知を受信して同期が延期され続けても、最初の通知から 60 秒経過すると同期が開始されます。
そのため、受信動作については 5 秒から 60 秒、OST ファイルの更新をサーバーにアップロードする場合は 15 秒から 60 秒のタイムラグがあるのです。
キャッシュ モードの同期は複数のアイテムをまとめて実行したほうが効率が良いため、このような動作となっています。
このタイムラグはレジストリ設定で変更も可能なのですが、既定のまま使用したほうが良いと思います。
変更したいということであれば、Exchange キャッシュモードでの同期タイミング (microsoft.com)を参照してください。
 
また、キャッシュ モードの同期は、サーバーとクライアントのアイテムを比較して差分を更新というようなものではなく、サーバーとクライアント双方でどこまで同期したかという情報を保持しており、同期の際には前回からのサーバーの変更・削除の情報をまとめてダウンロードするという仕組み (Incremental Change Synchronization) があります。
そのため、フォルダーに大量のアイテムがあったとしても、同期の際の通信量はあくまでも差分のデータ量だけになります。
 
Exchange Online などではメールボックスのサイズの上限が 100 GB というようなプランもありますが、キャッシュ モードで使用する OST ファイルのサイズの上限は 50 GB までとなっています。
また、そもそもクライアントでそれほど多くのディスク容量がないということもあります。
そのような場合には同期スライダーによりローカルにキャッシュする期間を 3 年から最短で 3 日まで短くし、ローカルに保持するデータ量を減らすことが可能です。
この設定を行うと、ローカルに保持されていないメールはフォルダーを表示した直後は表示されませんが、一覧の最後に表示される [Microsoft Exchange の詳細を表示するには、ここをクリックします] をクリックするとサーバーのメールが一覧に表示されます。
この時の表示はオンライン モードと同様、OST のアイテムではなくサーバーのアイテムを取得して表示しており、OST にキャッシュされるわけではありません。
そのため、キャッシュ期間外のアイテムの表示についてはオンライン モードと同等の速度となります。
 
キャッシュ モードで問題となることとしては、どこに OST ファイルを置くかというものがあります。
仮想デスクトップ環境などでは、ユーザーのデータをファイル サーバー上に置くことがありますが、OST ファイルは原則としてネットワーク経由でのアクセスがサポートされていません。
例外的いくつかの条件が整っている場合にサポートされますが、パフォーマンス観点ではローカルのディスクに比べると数段落ちることになります。
なお、2018 年にマイクロソフトが買収した FSLogix のプロファイル コンテナーという機能を使うと、OST のパフォーマンスが改善されるようです。
 
もう一つ問題となるのはキャッシュ モードの初期ダウンロードの通信量です。
メールボックスの使用量が 10 GB で同期スライダーによりすべての期間が指定されている場合、10 GB とは言いませんがそれなりの通信量は発生します。
初期ダウンロードの通信量を減らすには同期スライダーで同期期間を短くするか、[送受信]-[ダウンロードの設定] で [ヘッダーをダウンロード] を選択するというようなものが考えられます。
なお、オンライン モードとキャッシュ モードのどちらが通信量が少ないかという点についてですが、これに関しては使い方によるというのが答えになります。
オンライン モードはアイテムを参照しない限りダウンロードしないのですが、ローカルにキャッシュしないので参照するたびにダウンロードが発生することになります。
そのため、受信したメールを何度も表示したり、添付ファイルをローカルに保存せずに参照するというようなことをしていると、キャッシュ モードよりも通信量が多くなる可能性があります。 

オンライン モードとキャッシュ モードの使い分け

オンライン モードとキャッシュ モードのどちらを使うかという点についてですが、以下のような条件でない限り、キャッシュ モードを使用すべきと考えられます。

  • オンプレミスの Exchange サーバーを使用している
  • クライアントとサーバーの間にファイアウォールが存在しない
  • クライアントは高速な有線 LAN に接続されている

これらの条件を満たさない環境でオンライン モードを使用する場合は、パフォーマンスの低下やアイテムの保存失敗などのトラブルが発生する可能性があり、それらについては設定などで回避できるものではありません。
したがって、基本的にはキャッシュ モードを使用し、キャッシュ モードを使用できない場合は Outlook on the Web の使用を検討すべきといえるでしょう。

受信日時が一定の日数より前のメールを年と月のサブフォルダーに移動するスクリプト

受信トレイにたまったメールを整理する方法としては、以下のようなものがあります。

  • 古いアイテムの整理で個人用フォルダー ファイルに移動する
  • サブフォルダーを作ってルールまたは手動で移動する

しかし、古いアイテムの整理では個人用フォルダー ファイルの受信トレイに大量のメールがたまってしまったり、サブフォルダーへの移動ではどのフォルダーに振り分けるべきか悩ましいようなメールが出てきたりします。

いっそ受信日時の年と月のフォルダーに振り分けてしまえばいいのではないかと思い、そのようなスクリプトを作ってみました。

このスクリプトを実行すると EXPIRE_DAYS で指定した日数を経過している受信日時の年、月というフォルダー階層のサブフォルダーに移動されます。
例えば、2021 年 4 月に受信したメールであれば、受信トレイの下の 2021 というフォルダーのさらに下の 04 というフォルダーに移動されます。

Windows のタスク スケジューラーで毎月 1 日にこのスクリプトを実行するというようなタスクを作っておくとよいかもしれません。
スクリプトは以下の通りです。

'
On Error Resume Next
Const EXPIRE_DAYS = 60
Const olFolderInbox = 6
Dim olkApp
Dim fldInbox
Dim fldYear
Dim fldMonth
Dim i
Dim strYearMonth
' Outlook.Application を取得
Set olkApp = CreateObject("Outlook.Application")
' 受信トレイフォルダーを取得
Set fldInbox = olkApp.Session.GetDefaultFolder(olFolderInbox)
' 移動する場合はアイテムの最後から繰り返す
For i = fldInbox.Items.Count To 1 Step -1
     With fldInbox.Items(i)
         ' 受信日時が EXPIRE_DAYS で指定された日数よりも前なら
         If DateDiff("d", .ReceivedTime, Now) > EXPIRE_DAYS Then
             ' 受信日の年のフォルダーを取得
             strYear = Year(.ReceivedTime)
             Set fldYear = fldInbox.Folders(strYear)
             If Err.Number <> 0 Then
                 ' フォルダーがなければ作成
                 Set fldYear = fldInbox.Folders.Add(strYear)
                 Err.Clear
             End If
             ' 受信日の月のフォルダーを取得
             strMonth = Right("0" & Month(.ReceivedTime), 2)
             Set fldMonth = fldYear.Folders(strMonth)
             If Err.Number <> 0 Then
                 ' フォルダーがなければ作成
                 Set fldMonth = fldYear.Folders.Add(strMonth)
                 Err.Clear
             End If
             ' フォルダーに移動
             .Move fldMonth
         End If
     End With
Next

「親展」メールの特殊性

Outlook のあまり知られていない機能として、メールの秘密度という設定があります。
Exchange Online 環境ではリボンに秘密度がある場合もありますが、それとは別にメールのプロパティとして秘密度というものがあり、標準、個人用、親展、極秘 (バージョンによっては社外秘) が選べるようになっています。
これによってセキュリティが上がりそうに見えますが、実際にはメールを受信した側の情報バーに「このメッセージは xxx として扱ってください。」と表示されるだけで、転送などはできてしまいます。
そのため、あまりセキュリティを高める意味はなさそうなのですが、親展を選択した場合だけちょっと異なる動作をします。

例えば、自動仕分けルールでメールを転送していても、秘密度親展のメールは転送されません。
もし、外出先でメールを見るために自動転送をしていたというような場合、親展メールは転送されないので外出先では気づけないということがあります。

また、Exchange 環境で受信トレイを他の人に共有している場合、既定では親展メールが表示されません。
親展メールを参照できるようにするには、共有している側で代理人設定の [代理人に非公開に設定したアイテムへのアクセスを許可する] をオンにする必要があります。

このような動作があるため、秘密度に親展を設定する際には注意する必要があるといえるでしょう。

複数アカウントがあるプロファイルで閲覧ウィンドウのメールに返信、転送した際に送信アカウントのアドレスを Bcc 受信者として追加するマクロ

複数アカウントがあるプロファイルで新規メールや返信、転送の際に送信アカウントのアドレスを Bcc 受信者として追加するマクロのコメントにて以下のご要望をいただきました。


はじめまして。

Microsoft 365 Apps for business
バージョン 2102 (ビルド 13801.20266 クイック実行)

outlook超初心者で、マクロについては全く分かっていない者ですが、本記事を実行し、新規メール作成時に送信アカウントのアドレスを Bcc 受信者として追加することができました。
本当に助かりました。ありがとうございます。

お伺いしたいのが、受信メールを選んで、「返信」「全員に返信」「転送」ボタンを押してメールを作成すると、Bccに送信メールアドレスが入らないのですが、なぜでしょうか。
別に設定が必要なのでしょうか。

マクロが全く分かっていないので、おかしな質問をしているかもしれませんが、お時間ございましたら、ご回答いただけますと幸いです。
どうぞよろしくお願いいたします。


もともとのマクロはダブルクリックで開いたメールに対して返信や転送をすることを想定していました。
おそらく実現されたい動作はメッセージ一覧でメールを選択し、閲覧ウィンドウで返信や転送を実行した際に BCC が追加されるという動作だと思うのですが、その場合は Explorer オブジェクトの InlineResponse というイベントを使用する必要があります。
しかし、VBA ではイベントを配列に対して設定できないため、複数 Explorer オブジェクトがある場合に ThisOutlookSession 内では一つの Explorer しかイベント処理ができないということになるのです。

この制限を回避するためには、Explorer のイベントを処理するためのクラス モジュールを定義する必要があります。

手順としては、まず Visual Basic Editor を起動し、[Project1] を右クリックして [挿入]-[クラス モジュール] をクリックします。
すると、Class1 というクラス モジュールが作成されるので、(オブジェクト名) を “ExExplorer” に変更し、以下のコードをクラス モジュールのコードとして記載します。

'
Private WithEvents myExplorer As Explorer
'
Private myID As String
'
Public Sub Init(objExplorer As Explorer, strID As String)
     Set myExplorer = objExplorer
     myID = strID
End Sub
'
Private Sub myExplorer_Close()
     ThisOutlookSession.RemoveExplorer myID
End Sub
'
Private Sub myExplorer_InlineResponse(ByVal Item As Object)
     On Error Resume Next
     Dim recCurUser As Recipient
     Dim recBcc As Recipient
     ' アイテムがメールで一度も保存されていなければ処理
     If Item.MessageClass = "IPM.Note" And objMail.EntryID = "" Then
         ' いったん Outlook に制御を戻す
         DoEvents
         ' メールの送信アカウントのユーザー情報を取得
         Set recCurUser = Item.SendUsingAccount.CurrentUser
         ' 送信アカウントのアドレスを指定して受信者を追加
         Set recBcc = Item.Recipients.Add(recCurUser.Address)
         ' 受信者を Bcc に設定
         recBcc.Type = olBCC
         ' 受信者の名前解決を実行
         recBcc.Resolve
     End If
End Sub

次に、ThisOutlookSession に以下のコードを記載して保存し、Outlook を起動します。

'Private WithEvents myExplorers As Explorers
Private colExplorers As Collection
'
Private Sub Application_Startup()
     Set myExplorers = Application.Explorers
     Set colExplorers = New Collection
     If Not ActiveExplorer Is Nothing Then
         myExplorers_NewExplorer ActiveExplorer
     End If
End Sub
'
Private Sub myExplorers_NewExplorer(ByVal objExplorer As Explorer)
     Dim strID As String
     Dim oExExplorer As New ExExplorer
     strID = Timer & "-" & Rnd()
     oExExplorer.Init objExplorer, strID
     colExplorers.Add oExExplorer, strID
End Sub
'
Public Sub RemoveExplorer(strID As String)
     colExplorers.Remove strID
End Sub

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

誤って設定した予定アイテムのタイムゾーンを一括で修正するマクロ

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


初めまして。予定表のタイムゾーン設定で戸惑っています。誤って設定した個人用予定表のタイムゾーンを、一括して書き換える作業はVBAで可能でしょうか。以下URLを見ると、予定表のビュー設定の「ユーザー定義フィールド(User-defined fields)で TZ( を設定すると、Timezone が表示されるように読めるのですが、Outlook 2016 環境で、この設定(名前:TZ、種類:テキスト、書式:テキスト)をしても、各予定に設定しされたタイムゾーンは表示されず、vbaからも、それを参照、書き換える方法が判らずにおります。
https://www.slipstick.com/developer/code-samples/use-vba-get-appointments-time-zone/
ご教示いただければ幸甚です。


上記の URL のマクロは、ビューの列としては表示できないタイムゾーンの情報を AppointmentItemStartTimeZone というプロパティから取得し、TZ という名前のカスタム プロパティに設定することでアイテム一覧でもタイムゾーン表示ができるようにするというものです。
そのため、タイムゾーンを変更したいのであれば、StartTimeZone と EndTimeZone を置き換えればよいということになります。
ただ、StartTimeZone などは文字列のプロパティではなく、UTC からの時差や夏時間情報なども含んだオブジェクトとなっているため、設定する場合も TimeZone オブジェクトを指定する必要があります。
現在のシステムのタイムゾーン情報は Application.TimeZonesCurrentTimeZone プロパティにより取得できるので、システムと異なるタイムゾーンの予定アイテムのタイムゾーンを置き換える場合は以下のようなマクロとなります。

Public Sub FixTimeZone()
     Dim fldCalendar As Folder
     Dim tzCurrent As TimeZone
     Dim apptItem As AppointmentItem
     '
     Set fldCalendar = Session.GetDefaultFolder(olFolderCalendar)
     Set tzCurrent = Application.TimeZones.CurrentTimeZone
     For Each apptItem In fldCalendar.Items
         If apptItem.StartTimeZone.ID <> tzCurrent.ID Then
             apptItem.StartTimeZone = tzCurrent
             apptItem.EndTimeZone = tzCurrent
             apptItem.Save
         End If
     Next
End Sub

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

本文から取得したデータを項目別に Excel のシートに書き出すマクロ 2

本文から取得したデータを項目別に Excel のシートに書き出すマクロのコメントにて以下のご要望をいただきました。


はじめまして。いつも勉強させていただいています。
下記のとおり,「メールフォームから送信された内容を,項目ごとに既存のExcelファイル内の対応するセルに保存する方法」を教えていただきたく,コメントいたしました。
過去記事の「本文から取得したデータを項目別に Excel のシートに書き出すマクロ」を主に参考にさせていただき作成していたのですが,VBAの知識が浅いため応用的なことがなかなかできず苦戦しています。お力を貸していただけると幸いです。

メールの本文
=========================================================
以下の内容が送信されました。
問い合わせメールフォーム

■氏名
姓:山田
名:太郎

■会員番号
123456

■メッセージ1
あいうえお

■メッセージ2
かきくけこさしすせそ
たちつてと
=========================================================

Excelファイル
=========================================================
A1│B1│C1│D1
氏名│会員番号│メッセージ1│メッセージ2
A2│B2│C2│D2
山田太郎│123456│あいうえお│かきくけこさしすせそたちつてと
=========================================================

このように,メールの本文においては特定の項目の次の行に内容が表記されているので,改行の扱い方がわからず上手くいきません。
また,「名前」項目の内容にについては,姓名を結合させて保存したいと考えています。「メッセージ2」項目の内容については,複数行ある(改行が含まれる)ものもあるのですが,全てを一つのセルに収めたいと考えています。必要な部分(名前の“姓”や”名”を除いた部分)を抜き取って結合したり,複数行あるものを結合したりといった方法も,よくわからず上手くいきません。

以上,よろしくお願いします。

(利用環境:Windows10 Pro,Outlook2019)


項目のデータが同じ行だったり次の行だったりする場合には、データが次の行になる項目名の一部として改行コード (vbCrLf) を追加してしまえばよいでしょう。
複数の値を結合したければ、単に & で結合することができます。
複数行の結合ということですが、そもそも VBA では文字列は行という単位で扱っているわけではないので、取得した文字列に改行があったら Replace 関数で削除するという処理になります。

マクロを実行するタイミングについて記載がなかったので、受信時に自動的に保存するためのマクロと、表示しているメールのデータを保存するマクロを作成しました。

'
' 受信時に自動的に保存するためのマクロ
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     On Error Resume Next
     Dim objMail As MailItem
     Set objMail = Session.GetItemFromID(EntryIDCollection)
     If objMail.Body Like "*問い合わせメールフォーム*" Then
         ExportBodyToExcel2 objMail
     End If
End Sub
'
' 現在開いているメールの情報を保存するマクロ
'
Public Sub ExportBodyToExcelOpened()
     Dim objMail As MailItem
     ' メールをどのように開いているか確認
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objMail = ActiveInspector.CurrentItem
     Else
         Set objMail = ActiveExplorer.Selection(1)
     End If
     ExportBodyToExcel2 objMail
End Sub
'
' Excel へのエクスポートを行うマクロ
'
Public Sub ExportBodyToExcel2(objMail As MailItem)
     ' エクスポートする Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\book1.xlsx"
     Dim objBook As Object
     Dim objSheet As Object
     Dim r As Integer
     Dim strBody As String
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.Windows(1).Activate
     Set objSheet = objBook.Worksheets(1)
     ' 空行を探す
     r = 1
     While objSheet.Cells(r, 1) <> ""
         r = r + 1
     Wend
     strBody = objMail.Body
     ' セルに本文から取得したデータを格納
     objSheet.Cells(r, 1) = GetValueByToken(strBody, "姓:", vbCrLf) _
                          & GetValueByToken(strBody, "名:", vbCrLf)
     objSheet.Cells(r, 2) = GetValueByToken(strBody, "■会員番号" & vbCrLf, vbCrLf)
     objSheet.Cells(r, 3) = GetValueByToken(strBody, "■メッセージ1" & vbCrLf, "■メッセージ2")
     objSheet.Cells(r, 4) = GetValueByToken(strBody, "■メッセージ2" & vbCrLf, Chr(0))
     ' 変更したファイルを保存
     objBook.Save
     objBook.Close
End Sub
'
'  本文から指定された項目のデータを取得する関数
'
Private Function GetValueByToken(strBody As String, strToken As String, strEnd As String)
     Dim i As Integer
     Dim strLine As String
     Dim strValue As String
     Dim c As String
     ' データの開始位置を取得
     i = InStr(strBody, strToken)
     If i > 0 Then
         ' データの終了位置を取得
         strValue = Mid(strBody, i + Len(strToken))
         i = InStr(strValue, strEnd)
         ' 終了位置が取得できたらそこまでの文字列を取得
         If i > 0 Then
             strValue = Left(strValue, i - 1)
         End If
         ' 余計な改行と空白を削除
         strValue = Trim(Replace(strValue, vbCrLf, ""))
         GetValueByToken = strValue
     Else
         GetValueByToken = ""
     End If
End Function

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

受信トレイとそのサブフォルダーのメールの差出人を連絡先の表示名に書き換えるマクロ

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


https://outlooklab.wordpress.com/2007/03/24/%E9%80%A3%E7%B5%A1%E5%85%88%E3%82%92%E3%83%9E%E3%82%AF%E3%83%AD%E3%81%A7%E6%B4%BB%E7%94%A8%E3%81%99%E3%82%8B/

上記のマクロを受信トレイだけでなく、サブフォルダーにも適用させたいのですが、どうすればできますでしょうか。マクロ自体がよくわかっておらず適用させることで精いっぱいです。
お手数をおかけいたしますが、教えていただけますと幸いです。


上記のページの受信トレイの差出人の名前を置き換えるマクロをサブフォルダーに適用するには、再帰という方法を使用します。以下のようなマクロで実現できます。

'
Public Sub RewriteSenderInInboxRecursive()
     On Error Resume Next
     ' 受信トレイから下のフォルダーを処理
     RewriteSenderRecursive Session.GetDefaultFolder(olFolderInbox)
End Sub
' 指定したフォルダーとそのサブフォルダーを再帰的に処理するプロシージャ
Private Sub RewriteSenderRecursive(fldRoot As Folder)
     On Error Resume Next
     Dim objMail 'As MailItem
     Dim fldSub As Folder
     ' フォルダーのすべてのアイテムを処理
     For Each objMail In fldRoot.Items
         Dim objContact As ContactItem
         Dim strSenderAddress As String
         ' メールアイテムだけ処理
         If objMail.MessageClass = "IPM.Note" Then
             ' 差出人のアドレスを取得
             strSenderAddress = objMail.SenderEmailAddress
             ' アドレスから連絡先を検索
             Set objContact = FindContactByAddress(strSenderAddress)
             If Not objContact Is Nothing Then
                 ' 差出人名を変更して保存
                 objMail.SentOnBehalfOfName = objContact.FileAs
                 objMail.Save
             End If
         End If
     Next
     ' サブフォルダーを再帰的に処理
     For Each fldSub In fldRoot.Folders
         RewriteSenderRecursive fldSub
     Next
End Sub
' 連絡先フォルダーからアドレスに合致する連絡先を検索する関数
Private Function FindContactByAddress(strAddress As String)
     Dim objContacts 'As Folder
     Dim objContact As ContactItem
     '
     Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
     Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
         & "' or [Email2Address] = '" & strAddress _
         & "' or [Email3Address] = '" & strAddress & "'")
     Set FindContactByAddress = objContact
End Function

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

Access で RecordSet のデータをメール本文に表として埋め込むマクロ

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


こんにちは。お忙しい中恐縮ですが、よろしければアクセスVBAについて下記ご教示いただきたく、よろしくお願い致します。
行いたい内容は、「選択クエリの実行結果を、表としてメール本文に挿入する」というものです。
現在フォームを作成しており、ボタンを押せばメールが作成され、その本文にクエリの結果が記載されている、という状態を目指しているのですが、初心者がネット検索でやるには限界があり、行き詰っています。
「メール作成し、実行結果をエクセル等で添付」や、「単純にデータを本文挿入(=表形式ではないので幅が揃わない)」などのコードはあったのですが、目指す物にはならず…。
また、このクエリは毎月更新されるので、行数が変動するのもネックです(列数は変わりません)。
環境はwindows10/outlook2016です。
お手数おかけしますが、ご教示いただけますと幸いです。よろしくお願い致します。


Outlook のメールの本文に表を埋め込む方法としては、Inspector オブジェクトの WordEditor プロパティにより本文を編集するための Word の Document オブジェクトを取得し、Word の機能で表を作成するというものがあります。
以下のマクロは引数として指定された RecordSet の内容を HTML 形式のメールに表として埋め込む Access マクロのサブ プロシージャになります。

Private Sub CreateMailByRecordSet(recSet As RecordSet)
     ' Outlook の定数
     Const olMailItem = 0
     Const olFormatHTML = 2
     '
     Dim fldCount As Integer
     Dim recCount As Long
     Dim appOlk As Object ' Outlook.Application
     Dim objItem As Object ' Outlook.MailItem
     Dim wrdEditor As Object ' Word.Document
     Dim wrdTable As Object ' Word.Table
     Dim wrdRange As Object ' Word.Range
     Dim iCol As Integer
     Dim iRow As Integer
     ' レコードセットの情報取得
     With recSet
         ' 列数を取得
         fldCount = .Fields.Count
         ' すべての行を配列にコピー
         recArray = .GetRows
         ' 配列の行数を取得
         recCount = UBound(recArray, 2) + 2
     End With
     ' Outlook の Application オブジェクトを取得
     Set appOlk = CreateObject("Outlook.Application")
     ' 新規アイテムを作成
     Set objItem = appOlk.CreateItem(olMailItem)
     ' 本文形式を HTML に指定
     objItem.BodyFormat = olFormatHtml
     ' 表を挿入したアイテムを表示
     objItem.Display
     ' 新規アイテムの WordEditor オブジェクトを取得
     Set wrdEditor = objItem.GetInspector().WordEditor
     ' WordEditor にフォーカス設定
     wrdEditor.Activate
     ' 表の挿入位置を取得
     Set wrdRange = wrdEditor.Application.Selection.Range
     ' 本文に表を挿入
     Set wrdTable = wrdEditor.Tables.Add(wrdRange, recCount, fldCount)
     ' 表の作成
     With wrdTable
         ' 表のスタイルを指定
         .Style = "表 (格子)"
         ' 表の [タイトル行] をオン
         .ApplyStyleHeadingRows = True
         ' 表の [集計行] をオフ
         .ApplyStyleLastRow = False
         ' 表の [最初の列] をオン
         .ApplyStyleFirstColumn = True
         ' 表の [最後の列] をオフ
         .ApplyStyleLastColumn = False
         ' 表の [縞模様 (行)] をオン
         .ApplyStyleRowBands = True
         ' 表の [縞模様 (列)] をオフ
         .ApplyStyleColumnBands = False
         ' RecordSet の列名を最初の行にコピー
         For iCol = 1 To fldCount
             .Cell(1, iCol).Range.Text = recSet.Fields(iCol - 1).Name
         Next
         ' すべての行を表にコピー
         For iRow = 0 To recCount - 2
             For iCol = 1 To fldCount
                 If IsNull(recArray(iCol - 1, iRow)) Then
                     ' データが NULL だとエラーになるので <NULL> という文字列を設定
                     .Cell(iRow + 2, iCol).Range.Text = "<NULL>"
                 Else
                     ' 配列から表にコピー
                     .Cell(iRow + 2, iCol).Range.Text = recArray(iCol - 1, iRow)
                 End If
             Next
         Next
     End With
End Sub

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