2 通でペアになる承認メールを受け取ったら通知を送信するマクロ

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


お世話になっております。
いつも拝見し参考にさせていただいております。
AシステムとBシステムが承認されたときに通知・もしくはメールしたいです。
1つの案件(No:X000000000)に対し、A・Bの2システムで承認されなければ作業ができないようになっています。
Aシステム、Bシステムからそれぞれ承認メールは届きますが、タイミングもばらばらの為、確認に時間がかかっています。
メールの件名も違う為、ソートしても並ばないのです

Aシステムメール件名「【Aシステム】承認連絡(X000000000)」
Bシステムメール件名「[Bシステム]No-X000000000 が承認されました」

——–

Aシステムが届いたとき、Bシステムメールを確認して、同じX0000000があれば通知、もしくは自分に再度メール送信をするようなマクロは作れないでしょうか(A⇒B、B⇒Aどちらもあり得ます)

もしくは何かいい方法はないでしょうか?
メールが届いたら件名を編集してX000000000を先頭にするとかも考えたのですが…できそうでしょうか
ExcelはVBAをよく使いますが、outlookに関しては正直知識もなく、助けてください。よろしくお願い致します。


受信したメールが承認メールの件名の先頭に該当した場合に、受信済みメールから検索するようなマクロを作成すればご要望の実現は可能です。
ただ、例えば受信トレイのメールをすべて検索するというような処理にすると時間がかかってしまうので、承認メールは自動仕分けのルールで専用のフォルダーに振り分け、そのフォルダーの中を検索するようにしたほうが良いでしょう。
以下のマクロは「Aシステム」と「Bシステム」のいずれかを件名に含むメールは受信トレイの下の「承認メール」というフォルダーに振り分けている前提で動作します。

' ここをトリプルクリックでマクロ全体を選択できます。
' 受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Object
    
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     If objItem.MessageClass = "IPM.Note" Then
         CheckApproval objItem
     End If
End Sub

'
Private Sub CheckApproval(ByVal objMail As MailItem)
     ' 承認メールの件名の先頭部分を定義
     Const PREFIX1 = "【Aシステム】"
     Const PREFIX2 = "[Bシステム]"
     ' 承認コードの開始文字を定義
     Const CODE_START = "X"
     ' 承認コードの桁数指定
     Const CODE_LEN = 10
     ' 承認メールの振り分け先となる受信トレイのサブフォルダー
     Const APPROVAL_FOLDER = "承認メール"
     ' 承認通知メールの送信先
     Const NOTIFY_TO = "notify@example.com"
     Dim strFindPrefix As String
     Dim iStart As Integer
     Dim strFindCode As String
     Dim fldInbox As Folder
     Dim fldApproval As Folder
     Dim strFilter As String
     Dim objFound As Object
     Dim objNotify As MailItem
     ' 承認メールの一方が見つかったら、もう一方のメールを検索するための準備
     strFindPrefix = ""
     If Left(objMail.Subject, Len(PREFIX1)) = PREFIX1 Then
         strFindPrefix = PREFIX2
     End If
     If Left(objMail.Subject, Len(PREFIX2)) = PREFIX2 Then
         strFindPrefix = PREFIX1
     End If
     ' 承認メールでなければ終了
     If strFindPrefix = "" Then Exit Sub
     ' 承認コードの取得
     iStart = InStr(objMail.Subject, CODE_START)
     If iStart = 0 Then Exit Sub
     strFindCode = Mid(objMail.Subject, iStart, CODE_LEN)
     ' 受信トレイを取得
     Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
     ' 受信トレイのサブフォルダーの承認メール振り分け先フォルダーを取得
     Set fldApproval = fldInbox.Folders(APPROVAL_FOLDER)
     ' 承認メールのフォルダーのアイテムを検索
     For Each objFound In fldApproval.Items
         ' 受信した承認メールに対応するメールが見つかったら
         If Left(objFound.Subject, Len(strFindPrefix)) = strFindPrefix And _
            InStr(objFound.Subject, strFindCode) > 0 Then
             ' 承認通知メールを作成
             Set objNotify = CreateItem(olMailItem)
             objNotify.To = NOTIFY_TO
             objNotify.Subject = strFindCode & " は承認されました"
             objNotify.Body = strFindCode & " は以下の通り承認されました。" & vbCrLf & _
                 objFound.ReceivedTime & vbTab & objFound.Subject & vbCrLf & _
                 objMail.ReceivedTime & vbTab & objMail.Subject
             objNotify.Send
             ' 処理済みのメールを削除しない場合は以下の 2 行は削除
             objFound.Delete
             objMail.Delete
             ' メールを送信したら終了
             Exit Sub
         End If
     Next
End Sub

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

Excel ファイルの指定に従って添付ファイルを検索して添付し、送信するマクロ

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


はじめまして。
取引先へのそれぞれ異なる複数の添付ファイルをつけての一斉メール送信を行うにあたり、
初めてoutlookを使用することとなり、自動化に向けていろいろと情報収集をする中でこちらに
たどりつきました。
参考にできそうなアーカイブ[Excelのリストにしたがってファイルを添付して送信するマクロ]も少し内容が異なる様で、お力をお貸しいただければ幸いです。

OS Windows10
使用ソフト Excel2016 outlook2003
やりたいこと・環境
◯環境
社名とメールアドレスの一覧があります。(アドレス.xls)
ファイル名に社名のついたエクセルファイルとPDF(同一社あて複数の場合は社名のあとに数字)がそれぞれ別に1つのフォルダに入っています。
メール件名は統一です。
※Aフォルダ内にアドレス.xls / エクセルフォルダ / PDFフォルダ というイメージです。

◯やりたいこと
本文は基本的に1種類ですが、宛名のところに社名を差し込みたい。(アドレス.xlsに記載のもの)
各社宛に、エクセルファイルとPDFを添付して送信したい。
この時、添付したいエクセルファイルは1つですが、PDFは0〜複数あります。
アドレス.xlsに記載があっても添付ファイルがエクセル、PDF共に無い場合は送信しない。(いずれかの場合は送信)

どうぞよろしくお願いいたします。


まず、定型のメールを送信するために、あらかじめ件名と本文を記載したメールを [名前を付けて保存] で [Outlook テンプレート (*.oft)] として “アドレス.xls” と同じフォルダーに保存しておきます。
この時、本文で社名に置き換えられる位置に %COMPANY% という文字列を記載します。

例えば、本文中の「○○御中」の「○○」を社名に置き換えたい場合は、保存する OFT ファイルの本文には「%COMPANY%御中」と記載しておいてください。

このようにして保存した OFT ファイルを CreateItemFromTemplate メソッドにより開いて新規メールを作成し、宛先と本文を Excel に指定されたアドレスなどにより適宜設定し、Dir 関数でファイルを検索して添付することでご要望の動作は実現できます。

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

' ここをトリプルクリックでマクロ全体を選択できます。Public Sub SendExcelAndPDF()
     ' Excel ファイルなどのルート フォルダーを指定
     Const DATA_FOLDER = "c:\DATA"
     ' Excel ファイルを格納しているサブフォルダー名を指定
     Const EXCEL_FOLDER = "EXCEL"
     ' PDF ファイルを格納しているサブフォルダー名を指定
     Const PDF_FOLDER = "PDF"
     ' 社名とアドレスを格納している Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "アドレス.xls"
     ' 送信メールのテンプレート ファイル名を指定
     Const MAIL_TEMPLATE = "template.oft"
     ' テンプレート本文中の社名に置き換える文字列
     Const PLACE_HOLDER = "%COMPANY%"
     '
     Dim objBook
     Dim objSheet
     Dim r As Integer
     Dim msgSend As MailItem
     Dim strCompany As String
     Dim strFolder As String
     Dim strFile As String
     ' Excel ファイルを開く
     Set objBook = GetObject(DATA_FOLDER & "\" & EXCEL_FILE)
     objBook.Windows(1).Activate
     Set objSheet = objBook.sheets(1)
     ' 1 行目はタイトルとして使用し、2 行目からデータ
     r = 2
     ' データがなくなるまで繰り返し
     While objSheet.cells(r, 1) <> ""
         ' テンプレートからメールを作成
         Set msgSend = CreateItemFromTemplate(DATA_FOLDER & "\" & MAIL_TEMPLATE)
         ' セルの A 列から会社名を取得
         strCompany = objSheet.cells(r, 1)
         ' セルの B 列からアドレスを取得し、宛先に設定
         msgSend.To = objSheet.cells(r, 2)
         ' 本文中の特定文字列を会社名に置き換え
         msgSend.Body = Replace(msgSend.Body, PLACE_HOLDER, strCompany)
         ' Excel ファイルのフォルダーを取得
         strFolder = DATA_FOLDER & "\" & EXCEL_FOLDER & "\"
         ' Excel フォルダーから会社名で始まる Excel ファイルを検索
         strFile = Dir(strFolder & strCompany & "*.xls*")
         ' ファイルが見つかったら
         If strFile <> "" Then
             ' メールに添付
             msgSend.Attachments.Add strFolder & strFile
         End If
         ' PDF ファイルのフォルダーを取得
         strFolder = DATA_FOLDER & "\" & PDF_FOLDER & "\"
         ' PDF フォルダーから会社名で始まる PDF ファイルを検索
         strFile = Dir(strFolder & strCompany & "*.pdf")
         ' ファイルがなくなるまで繰り返す
         While strFile <> ""
             ' メールに添付
             msgSend.Attachments.Add strFolder & strFile
             ' 次のファイルを検索
             strFile = Dir()
         Wend
         ' 添付ファイルが 1 つでもあれば送信
         If msgSend.Attachments.Count > 0 Then
             msgSend.Send
         Else
         ' 添付ファイルがなければ送信せずに破棄
             msgSend.Close olDiscard
         End If
         ' 次の行に移動
         r = r + 1
     Wend
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

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

送信したメールを自動的に MSG ファイルとして保存するマクロ

受信したメールを自動的に MSG ファイルとして保存するマクロのコメントにて以下のご要望をいただきました。


こんにちは。こちらのマクロ非常に役立っています。ありがとうございます。

なお、マクロの送信メール版はできますでしょうか。お願いします。


通常、メールの送信の際の処理を行うマクロでは ItemSend イベントを使用するのですが、ItemSend イベントのタイミングではメールの送信直前の状態となっており、このメールを MSG として保存すると下書きのようになってしまいます。
そこで、送信済みアイテムが保存されるタイミングで MSG ファイルとして保存するマクロを作ってみました。
マクロは以下のようになります。

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

' ItemAdd イベントをハンドルするオブジェクト
Dim WithEvents mySentItems As Items
' Outlook 起動時に実行されるイベント
Private Sub Application_Startup()
     ' 送信済みアイテム フォルダーへのアイテム追加をハンドルするためのオブジェクト設定
     Set mySentItems = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
' 送信済みアイテム フォルダーへのアイテム追加の処理
Private Sub mySentItems_ItemAdd(ByVal Item As Object)
     Const SAVE_PATH = "C:\temp" ' MSG ファイルを保存するフォルダー
     Dim strSubject As String
     Dim strFileBase As String
     Dim strFileName As String
     Dim ch As String
     Dim c As Integer
     ' 件名をファイル名にする
     strSubject = Item.Subject
     ' 件名の前に送信日時をつける場合は以下を使用
      strSubject = Item.SentOn & " " & Item.Subject
     ' ファイル名に使用できない文字を _ に置き換える
     strFileBase = ""
     For i = 1 To Len(strSubject)
         ch = Mid(strSubject, i, 1)
         If InStr("\/:*?""|", ch) > 0 Then
             ch = "_"
         End If
         strFileBase = strFileBase & ch
     Next
     ' ファイル名の重複チェック
     c = 1
     strFileName = strFileBase & ".msg"
     ' 同名のファイルが存在したら
     While Dir(SAVE_PATH & "\" & strFileName) <> ""
         ' ファイル名に -連番 をつける
         strFileName = strFileBase & "-" & c & ".msg"
         c = c + 1
     Wend
     ' MSG ファイルとして保存する
     Item.SaveAs SAVE_PATH & "\" & strFileName, olMSG
End Sub

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

指定したキーワードを含むタスク アイテムを表示し、その概要を Excel ファイルに書き込むマクロ

タスクを終了状態にし、Excel ファイルに件名と所有者を書き込むマクロのコメントにて以下のご要望をいただきました。


いつもお世話になっております。

上記とは少し異なる内容ですが、Outlook上のタスク一覧より、特定の文字列が含まれた
件名を取得し、そのタスクを開く事は可能なのでしょうか?

難しい場合、そのタスク上にある件名、期限、所有者、本文等の情報をExcelに書き出すことは可能でしょうか?

Excel上から特定のタスクを生成する所までは上手くできたのですが、そのタスクをどのようにクローズしたら良いか悩んでおります。

何か良い案などありましたらご教示の程宜しくお願い致します。
不明な点などありましたらご連絡下さい。


特定の文字列を含む件名のタスク アイテムを取得するには以下のような処理を行います。

  1. Session の GetDefaultFolder メソッドに olFolderTasks を指定してタスク フォルダー を取得する
  2. 取得したフォルダーの Items コレクションでアイテムを取得する
  3. 取得したアイテムの Subject にキーワードが含まれるかを InStr 関数で確認する

このようにして見つかったアイテムを表示する場合、取得した TaskItem の Display メソッドを実行します。
今回は表示するついでに Excel ファイルに件名などを書き出すマクロにしてみました。

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

Public Sub OpenTaskAndWriteToExcel()
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\file.xlsx"
     Dim objBook
     Dim objSheet
     Dim r As Integer
     Dim strKeyword As String
     Dim fldTask As Folder
     Dim itmTask As TaskItem
     ' キーワードの入力
     strKeyword = InputBox("キーワード")
     ' キーワードが入力されなければ終了
     If strKeyword = "" Then
         Exit Sub
     End If
     ' 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
     ' タスク フォルダーを取得
     Set fldTask = Session.GetDefaultFolder(olFolderTasks)
     ' すべてのタスク アイテムを検索
     For Each itmTask In fldTask.Items
         ' 件名にキーワードを含んでいたら
         If InStr(itmTask.Subject, strKeyword) > 0 Then
             ' Excel にデータを転記
             With objSheet
                 .Cells(r, 1) = itmTask.Subject
                 .Cells(r, 2) = itmTask.DueDate
                 .Cells(r, 3) = itmTask.Owner
                 .Cells(r, 4) = itmTask.Body
             End With
             ' タスク アイテムを開く
             itmTask.Display
         End If
     Next
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

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

送信済みアイテムのメールに対する返信を表示するマクロ

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


いつも参考にさせていただいています。

選択されたメールに対して返信したか確認し、返信済みの場合、その返信メールのオブジェクトMailItem)を取得する方法を参考にさせていただき、送信したメール(送信済みメール)に対して、回答が届いているか、届いていたら受信トレイからメールアイテムを確認して開く方法を模索しています。Outlook2016では、送信メールにEntryIDが付与されないという記事を読み、行き詰っています。なにか良い案があれば教えていただけますでしょうか。
どうぞよろしくお願いいたします。


Outlook でメールの送信を行った場合、送信済みアイテムには Message ID が格納されないため、メールスレッドの紐づけを行うのが困難となります。
そこで、メールの件名から RE: などを除いた文字列をキーとして検索し、送信済みアイテムの送信日時よりも後に受信したメールを表示するマクロを作成してみました。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub GetReplyFromSentItems()
     Dim msgSent As MailItem
     Dim fldInbox As Folder
     Dim strFilter As String
     Dim colReply As Items
     Dim msgReply As MailItem
     ' 現在表示しているアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set msgSent = ActiveInspector.CurrentItem
     Else
         Set msgSent = ActiveExplorer.Selection(1)
     End If
     ' 受信トレイを取得
     Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
     ' スレッドで検索
     strFilter = "[スレッド] = '" & msgSent.ConversationTopic & "'"
     Set colReply = fldInbox.Items.Restrict(strFilter)
     ' 同じスレッドのメールを確認
     For Each msgReply In colReply
         ' 受信日時が送信日時より後のメールなら返信とみなす
         If msgReply.ReceivedTime > msgSent.SentOn Then
             msgReply.Display
             Exit Sub
         End If
     Next
     ' 返信が見つからなければエラー表示
     MsgBox "返信は見つかりませんでした。"
End Sub

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

To か Cc に特定のドメインが含まれている場合に Bcc を追加するマクロ

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


はじめまして。
Outlook2016を使用しています。
ToまたはCcに、特定のドメインが含まれている場合、Bccを追加するマクロを探しています。
「社外のアドレスを宛先に含む場合のみ BCC を追加するマクロ」はありましたが、社外一律ではなく、特定ドメインを含む場合のみ実行されることが希望です。


特定のドメインの受信者が含まれているかどうかは MailItem の Recipients コレクションに含まれる Recipient オブジェクトの Address で確認できます。
該当するメールであることが確認出来たら、Recipients の Add メソッドで受信者を追加し、Recipient オブジェクトの Type に olBcc を指定すると BCC 受信者として追加ができます。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Const BCC_ADDRESS = "bcc@example.com"     ' BCC の宛先を指定
     Dim arrDomains
     Dim oneDomain
     Dim recOne As Recipient
     Dim bNeedBcc As Boolean
     Dim recBcc As Recipient
     ' BCC を入れる宛先ドメインを指定
     arrDomains = Array("example.com", "example.co.jp")
     bNeedBcc = False
     ' 送信メールのすべての受信者をチェック
     For Each recOne In Item.Recipients
         For Each oneDomain In arrDomains
             ' 受信者のアドレスのドメインが該当ドメインなら
             If recOne.Address Like "*@" & oneDomain Then
                 ' BCC 送信フラグをオン
                 bNeedBcc = True
                 Exit For
             End If
         Next
         If bNeedBcc Then Exit For
     Next
     ' BCC 送信フラグがオンなら
     If bNeedBcc Then
         ' BCC 送信先を宛先に追加
         Set recBcc = Item.Recipients.Add(BCC_ADDRESS)
         recBcc.Type = olBCC
         recBcc.Resolve
     End If
End Sub

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

メールの件名から取得した文字列をバーコードとして本文の右側に追記し、印刷するマクロ

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


OutlookVBA初心者です。
1クリックで以下の作業を行いたいと考えております。
(環境:Win10/Outlook2013)

・本文の一部だけを抜粋してヘッダーまたはフッターに表示
 もしくは件名の後ろから7文字
・抜粋した文字列をバーコード表示(バーコードフォントは入っております)
・クイック印刷

抜粋する条件は指定文字列の後ろの7文字です。
(バーコードフォントはBC39のため前後に*を結合する必要があります)

また、実現出来たら他の(遠隔地の営業所)PCにも同様の設定を行いたいのですが、
直接使用しているPCにコードをコピペする以外に方法はありませんでしょうか?

お力添えいただけますと幸いです。
何卒宜しくお願い致します。


バーコードの表示が可能なフォントがインストールされている場合、HTML のタグでフォントを指定することにより文字列をバーコードとして表示することが可能です。
以下のマクロはバーコードのフォントの名前が “Bar-Code 39” である場合に本文の右上にバーコードを表示するものです。
なお、コメントでも返信しましたが、マクロをコピーペースト以外で配布することはできず、配布が必要な場合はアドインとして実装する必要があります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub PrintWithBarcode()
     Const BARCODE_FONT = "Bar-Code 39"  ' バーコードのフォントの名前
     Const BARCODE_SIZE = "20.0pt"       ' バーコードのサイズ
     Const BARCODE_LENGTH = 7            ' バーコード文字列の長さ
     Dim objItem As MailItem
     Dim strBarcode As String
     Dim strHtml As String
     Dim iBodyStart As Integer
     Dim objPrint As MailItem
     ' 現在表示中のメールを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     ' メールの件名の末尾の文字を取得
     strBarcode = Right(objItem.Subject, BARCODE_LENGTH)
     ' バーコード表示用の HTML 文字列生成
     strBarcode = "<p align='right' style='font-family:" & BARCODE_FONT _
         & ";font-size:" & BARCODE_SIZE & "'>*" & strBarcode & "*</p>"
     ' 本文を HTML で取得
     strHtml = objItem.HTMLBody
     ' BODY タグの開始位置を取得
     iBodyStart = InStr(LCase(strHtml), "<body")
     If iBodyStart > 0 Then
         ' BODY タグの終了位置を取得
         While iBodyStart <= Len(strHtml) And Mid(strHtml, iBodyStart, 1) <> ">"
             iBodyStart = iBodyStart + 1
         Wend
     End If
     iBodyStart = iBodyStart + 1
     ' 印刷用にメールをコピー
     Set objPrint = objItem.Copy
     ' 本文にバーコードのタグを追加
     objPrint.HTMLBody = Left(strHtml, iBodyStart - 1) & strBarcode & Mid(strHtml, iBodyStart)
     ' メールを印刷
     objPrint.PrintOut
     ' 印刷用のメールを閉じて削除
     objPrint.Close olDiscard
     objPrint.Delete
End Sub

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

決まった件名のメッセージを受信したら、データを Excel ファイルに保存するマクロ (複数行対応バージョン)

決まった件名のメッセージを受信したら、データを Excel ファイルに保存するマクロのコメントにて以下のご要望をいただきました。


抽出したいキーワードが以下のように、各項目の1行下に記載されている場合は、
どのように記述すればよいでしょうか。
キーワードは改行含めて複数行になることもあります。
本文
・番号
〇〇○
・氏名
△△△
・住所
◻︎◽︎◻︎
・生年月日
××
・依頼内容
☆☆☆
☆☆☆☆☆☆
☆☆☆☆☆☆☆☆☆


抽出する文字列が複数行にまたがる可能性があるとなると、改行コードをデータの終わりとして使用することができません。
そのため、次のキーワードまでの文字列を抽出することになります。

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

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     SaveToExcel EntryIDCollection
End Sub
'
Private Sub SaveToExcel(ByVal EntryIDCollection As String)
     Const AUTO_SAVE_TITLE = "タイトル" ' 自動処理するメールの件名
     Const EXCEL_FILE = "c:\temp\request.xlsx" ' 保存する Excel ファイルの名前
     Dim i As Integer
     Dim myMsg
     ' メッセージの取得
     Set myMsg = Session.GetItemFromID(EntryIDCollection)
     ' 指定の件名のメールのみ処理を実行
     If myMsg.Subject = AUTO_SAVE_TITLE Then
         Dim objBook
         Dim objSheet
         Dim r As Integer
         Dim arrColumn As Variant
         Dim iCur As Integer
         Dim iNext As Integer
         ' 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
         ' 取得する情報のキーワードを定義
         arrColumn = Array("・番号", "・氏名", "・住所", "・生年月日", "・依頼内容")
         iCur = 1
         ' 最初のキーワードまで移動
         GetValueToToken myMsg.Body, arrColumn(0), iCur
         For i = 1 To UBound(arrColumn)
             ' 次のキーワードまでの文字列を習得して Excel に転記
             objSheet.Cells(r, i) = GetValueToToken(myMsg.Body, arrColumn(i), iCur)
         Next
         ' 最後のキーワードのデータは本文の最後までを取得
         objSheet.Cells(r, i) = TrimCrLf(Mid(myMsg.Body, iCur))
         ' Excel ファイルを閉じる
         objBook.Close True
     End If
End Sub
' 次のキーワードまでの文字列を取得する関数
Private Function GetValueToToken(strBody As String, strToken As Variant, iPtr As Integer) As String
     Dim iNext As Integer
     Dim strValue As String
     ' 次のキーワードまでの文字位置を取得
     iNext = InStr(iPtr, strBody, strToken)
     If iNext > 0 Then
         ' 現在の位置から次のキーワードまでの文字列を取得
         strValue = Mid(strBody, iPtr, iNext - iPtr)
         GetValueToToken = TrimCrLf(strValue)
         ' 現在の位置をキーワードの終わりまで移動
         iPtr = iNext + Len(strToken)
     Else
         GetValueToToken = ""
     End If
End Function
' 文字列の前後の余計な改行を削除する関数
Private Function TrimCrLf(strValue As String) As String
     While Left(strValue, 1) = vbCr Or Left(strValue, 1) = vbLf
         strValue = Right(strValue, Len(strValue) - 1)
     Wend
     While Right(strValue, 1) = vbCr Or Right(strValue, 1) = vbLf
         strValue = Left(strValue, Len(strValue) - 1)
     Wend
     TrimCrLf = strValue
End Function

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

Excel で選択している範囲を本文にコピーするマクロ

Excel のデータを Outlook の本文に表としてコピーするマクロのコメントにて以下のご要望をいただきました。


すごく初歩的な質問だと思うのですが、下記の部分を「既にエクセル上で選択している選択範囲」にするスクリプトはどのようなものになりますでしょうか?
‘ 転記する Excel ファイルの列の開始位置
Const COL_START = 1
‘ 転記する Excel ファイルの列の数
Const NUM_COLS = 5
‘ 転記する Excel ファイルの行の開始位置
Const ROW_START = 1
‘ 転記する Excel ファイルの行の数
Const NUM_ROWS = 10


エクセル上で選択している範囲を取得するには、Excel の Application オブジェクトの Selection プロパティを使用します。
Selection で取得した Range オブジェクトの Cells プロパティは選択範囲のセルのみを含んでいるので、常に開始位置は 1 となり、列の数や行の数は Range オブジェクトの Columns.Count と Rows.Count で取得できます。
以前のマクロを選択範囲からのコピーに変更すると以下のようになります。
なお、このマクロは Excel のマクロとなります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CopySelectedToMail()
      ' Outlook の定数
      Const olMailItem = 0
      Const olFormatRichText = 3
      '
      Dim rgSel As Range
      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 iColMax As Integer
      Dim iRowMax As Integer
      Dim iCol As Integer
      Dim iRow As Integer
      ' 現在選択している範囲を取得
      Set rgSel = Application.Selection
      iColMax = rgSel.Columns.Count
      iRowMax = rgSel.Rows.Count
      ' Outlook の Application オブジェクトを取得
      Set appOlk = CreateObject("Outlook.Application")
      ' 新規アイテムを作成
      Set objItem = appOlk.CreateItem(olMailItem)
      '
      objItem.BodyFormat = olFormatRichText
      ' 新規アイテムの WordEditor オブジェクトを取得
      Set wrdEditor = objItem.GetInspector().WordEditor
      ' WordEditor にフォーカス設定
      wrdEditor.Activate
      ' 表の挿入位置を取得
      Set wrdRange = wrdEditor.Application.Selection.Range
      ' 本文に表を挿入
      Set wrdTable = wrdEditor.Tables.Add(wrdRange, iRowMax, iColMax)
      '
      With wrdTable
          ' 表のスタイルを指定
          .Style = "表 (格子)"
          ' 表の [タイトル行] をオン
          .ApplyStyleHeadingRows = True
          ' 表の [集計行] をオン
          .ApplyStyleLastRow = False
          ' 表の [最初の列] をオン
          .ApplyStyleFirstColumn = True
          ' 表の [最後の列] をオン
          .ApplyStyleLastColumn = False
          ' 表の [縞模様 (行)] をオン
          .ApplyStyleRowBands = True
          ' 表の [縞模様 (列)] をオフ
          .ApplyStyleColumnBands = False
          ' Excel の表のデータを本文のテーブルに転記
          For iCol = 1 To iColMax
              For iRow = 1 To iRowMax
                  ' .Cell は本文の表のセル
                  ' Cells は Excel の表のセル
                  .Cell(iRow, iCol).Range.Text = _
                      rgSel.Cells(iRow, iCol).Value
              Next
          Next
      End With
      ' 表を挿入したアイテムを表示
      objItem.Display
End Sub

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