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

メールの内容を Excel ファイルにかき出すマクロ のコメントにて以下のご要望をいただきました。


はじめまして。
横からの質問で申し訳ありません。
どうしても自分では解決できずなんとかお力をお借りしたいと思います。

メールの本文中、

【 ご予定日 】 12月
【 日 】 31日
【 泊数 】 1泊
【 名前 】 山田 太郎
【 郵便番号 】 4562215
【 ご住所 】 愛知県豊明市西町5丁目111-111
【 マンション名等 】豊明マンション101
【 Email 】 taroyamada@yahoo.co.jp
【 tel1 】 0902200000
【 ご予約人数 】 2人
【 小学生以下人数 】 1人

のように項目ごとのフォーム送信がある場合、エクセルの2行目以降のセルに

(A1) (B1) …
ご予定日 日 泊数 名前 郵便番号 …
(A2) (B2) …
12 31 1 山田 太郎 4562215 …

のように①、メール本文内の項目の後の文字列を抽出し、エクセルの対象項目に対して個別にエクスポートすることは可能なのでしょうか?
またその折②、日にち、泊数などは数字のみ抽出できればうれしいです。
outlookのエクスポート機能はwordの差し込みフィールドのように使えて便利そうなのですが2003以降のバージョンには対応していないようですし、本文中の項目までは当然読み込めませんのでなんとかマクロで解決できればと思っております。
ただ、マクロはネットで引っ張りながらさわるぐらいしかできません。
こういった投稿、コメントに不慣れで甚だ不躾ではございますが是非ご教示頂ければ幸いです。
宜しくお願い申し上げます。

追記です。
出来れば既存のエクセルデータsheet内のセルに挿入できればと考えています。


本文から項目を取り出すというような便利な関数は Outlook には用意されていませんが、VBA の文字列検索関数を使って実現することはできます。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportBodyToExcel()
    ' エクスポートする 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
    ' メールをどのように開いているか確認
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        strBody = ActiveInspector.CurrentItem.Body
    Else
        strBody = ActiveExplorer.Selection(1).Body
    End If
    ' セルに本文から取得したデータを格納
    objSheet.Cells(r, 1) = GetValueByToken(strBody, "ご予定日", True)
    objSheet.Cells(r, 2) = GetValueByToken(strBody, "日", True)
    objSheet.Cells(r, 3) = GetValueByToken(strBody, "泊数", True)
    objSheet.Cells(r, 4) = GetValueByToken(strBody, "名前", False)
    ' 郵便番号は文字列として保存
    objSheet.Cells(r, 5) = "'" & GetValueByToken(strBody, "郵便番号", False)
    objSheet.Cells(r, 6) = GetValueByToken(strBody, "ご住所", False)
    objSheet.Cells(r, 7) = GetValueByToken(strBody, "マンション名等", False)
    objSheet.Cells(r, 8) = GetValueByToken(strBody, "Email", False) 
    ' 電話番号は文字列として保存
    objSheet.Cells(r, 9) = "'" & GetValueByToken(strBody, "tel1", False)
    objSheet.Cells(r, 10) = GetValueByToken(strBody, "ご予約人数", True)
    objSheet.Cells(r, 11) = GetValueByToken(strBody, "小学生以下人数", True)
    ' 項目を追加したければ以下のフォーマットで追加 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", True) '数字のみ取り出す場合 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", False) '文字列として取り出す場合
    ' 変更したファイルを保存
    objBook.Save
    objBook.Close
    MsgBox "保存しました。"
End Sub
'
'  本文から指定された項目のデータを取得する関数
'
Private Function GetValueByToken(strBody As String, strToken As String, bNumOnly As Boolean)
    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 = ""
        strLine = Mid(strBody, i + Len(strToken) + 4)
        i = InStr(strLine & vbCrLf, vbCrLf)
        ' 余計な空白を削除
        strValue = Trim(Left(strLine, i - 1))
        If bNumOnly Then  ' 数字のみが指定された場合
            For i = 1 To Len(strValue)
                c = Mid(strValue, i, 1)
                If c < "0" Or "9" < c Then
                    strValue = Left(strValue, i - 1)
                    Exit For
                End If
            Next
        End If
        GetValueByToken = strValue
    Else
        GetValueByToken = ""
    End If
End Function

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

メール本文中のハイパーリンクを置き換えるマクロ

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


お世話になります。
仕事でOutlook2010をOffice365サーバー環境で使用しています。
Outlookメール本文中のハイパーリンクを変更したい件でご相談させてください。
今回、会社の組織変更で、Windowsファイルサーバーの格納先パスを変更する必要が出てきました。
従来、
\\Fsrv02\913-ABC\01グループ公開\50役立つ資料」のパスを
\\Fsrv02\602-XYZ\001グループ公開\50役立つ資料」に変更する必要がある状況です。
その際、メール本文中にあるハイパーリンクを置き換えしたいのです。
メールには、
テキスト形式
HTML形式
リッチテキスト形式が混在しています。
メールは複数あり、フォルダー内すべてのメール本文を対象に検索して置き換えたい状況です。
できれば、テキストファイルに、変更前パスと、変更後パスを指定して、汎用性がもたせたら尚うれしいです。
弊サイトの情報も見させていただいたのですが、私の探し方が未熟なため、サンプルプログラムとして使わせていただけそうなものが見つかりませんでした。
どうか、宜しくお願い申し上げます。



以下のようなマクロで実現できます。 REPLACE_FILE で指定したファイル名のテキストファイルに、変更前のパスと変更後のパスを 1 行ずつタブで区切って格納してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplaceLinksInFolder()
    Const REPLACE_FILE = "c:\temp\replacelinks.txt"
    Dim objFSO As Object
    Dim stmFile As Object
    Dim strReplace As String
    Dim arrLine As Variant
    Dim arrOld() As String
    Dim arrNew() As String
    Dim i As Integer
    ' パスの変換情報をファイルから読み込み
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set stmFile = objFSO.OpenTextFile(REPLACE_FILE)
    strReplace = stmFile.ReadAll()
    stmFile.Close
    arrLine = Split(strReplace, vbCrLf)
    ReDim arrOld(UBound(arrLine))
    ReDim arrNew(UBound(arrLine))
    For i = LBound(arrLine) To UBound(arrLine)
        Dim arrField As Variant
        If InStr(arrLine(i), vbTab) = 0 Then
            ReDim Preserve arrOld(i)
            ReDim Preserve arrNew(i)
            Exit For
        End If
        arrField = Split(arrLine(i), vbTab)
        arrOld(i) = arrField(0)
        arrNew(i) = arrField(1)
    Next
    ' アイテムごとにパスの変換を行う
    Dim objItem As MailItem
    For Each objItem In ActiveExplorer.CurrentFolder.Items
        If objItem.BodyFormat = olFormatPlain Then
            ' テキスト形式なら単純なテキスト置き換え
            Dim strNewBody As String
            strNewBody = objItem.Body
            For i = LBound(arrOld) To UBound(arrOld)
                strNewBody = Replace(strNewBody, arrOld(i), arrNew(i))
            Next
            If strNewBody <> objItem.Body Then
                objItem.Body = strNewBody
                objItem.Save
            End If
        Else
            ' HTML または RTF の場合は Word コンポーネントを使用して置き換え
            Dim objInsp As Inspector
            Dim objWord As Object ' Word.Document
            Dim objLink As Object ' Word.Hyperlink
            Dim bFound As Boolean
            Set objInsp = objItem.GetInspector()
            Set objWord = objInsp.WordEditor
            ' テキスト置き換えを可能にするため、[メッセージの編集] を実行
            objInsp.Display
            objInsp.CommandBars.ExecuteMso "EditMessage"
            bFound = False
            For Each objLink In objWord.Hyperlinks
                For i = LBound(arrOld) To UBound(arrOld)
                    ' リンクアドレスが置き換え前の文字列で始まる場合は置き換え
                    If objLink.Address Like arrOld(i) & "*" Then
                        bFound = True
                        objLink.Address = Replace(objLink.Address, arrOld(i), arrNew(i))
                        If objLink.TextToDisplay Like arrOld(i) & "*" Then
                            objLink.TextToDisplay = Replace(objLink.TextToDisplay, arrOld(i), arrNew(i))
                        End If
                    End If
                Next
            Next
            If bFound Then
                objItem.Save
            End If
            objInsp.Close olDiscard
        End If
    Next
End Sub

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

日付の文字列を設定するいくつかの方法

Outlook の予定表を CSV ファイルにエクスポートするマクロ Ver 2 のコメントにて以下のご要望をいただきました。


Outlookの予定データを日報管理として
Accessかexcelにインポートして活用したいと考えています。
各個人でExportする事を前提として

以下の文章(一部ここでは省略)を除いて
ThisOutlookSessionにコピペしマクロ登録致しました。

‘ 他人の予定を出力するマクロ
Public Sub ExportOthersCalendar()
中略
End Sub

デジタル署名の作成、OUTLOOKも再起動しマクロを実行
画面ではなんの変化もなく一瞬不安になりましたが、
エクスポート先のファイル名とされている C: ドライブ直下を確認すると
mycalendar.csv が作成されていた。
中身を確認すると当月の予定がExportされていました。

以下の点を変更したいのですが…。

Q1:日単位や週単位としたい場合はどのようにすればよいのでしょうか?
マクロの文章に以下の説明があるのですが…

dtExport = Now ‘ 来月の予定をエクスポートする場合は Now の代わりに DateAdd(“m”,1,Now) を使用します。
‘ 月単位ではなく任意の単位にする場合は以下の記述を変更します。
strStart = Year(Now) & “/” & Month(Now) & “/1 00:00”
strEnd = DateAdd(“m”, 1, CDate(strStart)) & ” 00:00″
DateAdd 関数を調べてみました。m=月、d=日、ww=週が引数 interval の設定値のようです。
本日の予定をエクスポートしたい場合
“m”を”d”と変更することでよいのでしょうか?

dtExport = Now

dtExport = DateAdd(“d”,-1,Now)

上記部分のみの変更では当月の予定がExportされます。
下記部分も追加変更しましたが、
本日(2016/11/17)ではなく201611/01のデータがExportされました。

strEnd = DateAdd(“m”, 1, CDate(strStart)) & ” 00:00″

strEnd = DateAdd(“d”, 1, CDate(strStart)) & ” 00:00″

私の力ではこれ以上は無理です。
本日、昨日、先週の条件でエクスポートするにはどのように変更すればよいのでしょうか?

質問2:日付のデータの形式について
Exportされた日付データは 2016/11/17 (木) という曜日まで表示されている形式です。
2016/11/17のような 曜日を含まない形式でのExportはできないでしょうか?

どうかご指南頂ければ幸いです。
よろしくお願い申し上げます。



まず、質問 1 について説明します。

もともとのコードは、1 か月分を出力することを想定しているため、dtExport で指定した日付から年月を取得し、その月の 1 日を strStart としています。
そのため、日ごとの指定をしたい場合は、FormatDateTime 関数で日付のみを取り出した文字列を strStart と strEnd に指定する必要があります。
「本日」の場合は以下のような記述になります。

dtExport = Now
strStart = FormatDateTime(dtExport, vbShortDate)
strEnd = FormatDateTime(DateAdd("d", 1, dtExport), vbShortDate)

次に、「昨日」の場合は以下のような記述になります。

dtExport = Now
strStart = FormatDateTime(DateAdd("d", -1, dtExport), vbShortDate)
strEnd = FormatDateTime(dtExport, vbShortDate)

「先週」はちょっと厄介ですね。今日の日付が月曜日でも金曜日でも、「先週」をさす場合は通常日曜日から土曜日になるでしょう。
日付から曜日を取り出すのは Weekday 関数ですが、その値 + 6 日を引くと、先週の日曜日の日付になり、それが範囲の開始になります。
また、終了日は開始日の 7 日後です。
したがって、「先週」の範囲指定は以下のようになります。

dtExport = DateAdd("d", –(Weekday(Now) + 6), Now))
strStart = FormatDateTime(dtExport, vbShortDate)
strEnd = FormatDateTime(DateAdd("d", 7, dtExport), vbShortDate)

次に質問 2 についてですが、曜日を省いた文字列はすでに登場した FormatDateTime 関数により取得可能であり、本来なら FormatDateTime( 日付, vbShortDate) で曜日なしの日付文字列が取得できるはずです。
もし、Windows の設定などで曜日がついてしまうようであれば、以下のように Format 関数で日付だけを取得するという方法もあります。

""",""" & Format(objAppt.Start, "yyyy/mm/dd") & _

Outlook 2016/2013 の累積的な修正プログラム 2016 年 12 月分がリリース

12/6 に Office 2016 および Office 2013 の累積的な修正プログラムがリリースされました。
以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

December 6, 2016, update for Outlook 2016 (KB3127988)
11 件の不具合修正が行われています。

Exchange アドインの修正

December 6, 2016, update for Office 2016 (KB2920703)
Outlook 2016 の Exchange アドインの不具合が 3 件修正されています。

Word 2016 の修正

December 6, 2016, update for Word 2016 (KB3127984)
Outlook 2016 関連の不具合が 2 件修正されています。

Office 2013

Outlook 2013 の修正

December 6, 2016, update for Outlook 2013 (KB3127975)
14 件の不具合修正が行われています。

Windows 転送ツールで転送後に Outlook 2016 で連絡先がアドレス帳に表示されない現象について

以前、Windows 転送ツールで転送後に Outlook で連絡先がアドレス帳に表示されない現象について回避するスクリプトを作成し、Outlook 2013 に対応するスクリプトも作成しました。

今回、Outlook 2016 に対応するものもご要望いただいたため、2016 用も作成しました。

スクリプトは以下の通りです。
この内容をメモ帳などで拡張子 vbs として保存し、そのファイルをダブルクリックして実行すると、既定の MAPI プロファイルの Outlook アドレス帳の設定を初期化し、連絡先フォルダが追加できるようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Option Explicit
'
Const HKEY_CURRENT_USER = &H80000001
Const OUTLOOK_KEY = "Software\Microsoft\Office\16.0\Outlook"
Const MAPI_PROFILE_KEY = "Software\Microsoft\Office\16.0\Outlook\Profiles"
Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
Const PR_AB_PROVIDERS = "01023d01"
'
Dim stdRegProv
Dim strDefaultProfile
Dim strProfileKey
Dim strServicesKey
Dim arrServiceUIDs
Dim iCount
Dim i,j
Dim strServiceKey
Dim arrData
'
Set stdRegProv = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
stdRegProv.GetStringValue HKEY_CURRENT_USER, OUTLOOK_KEY, "DefaultProfile", strDefaultProfile
strProfileKey = MAPI_PROFILE_KEY & "\" & strDefaultProfile & "\"
strServicesKey = strProfileKey & MAPI_SERVICES_KEY
'
stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_AB_PROVIDERS, arrServiceUIDs
iCount = (UBound(arrServiceUIDs)+1)/16
For i=0 To iCount-1
strServiceKey = ""
For j=0 To 15
strServiceKey = strServiceKey & Right("0" & Hex(arrServiceUIDs(i*16+j)), 2)
Next
If stdRegProv.GetBinaryValue(HKEY_CURRENT_USER, strProfileKey & strServiceKey, "11026626", arrData ) = 0 Then
Dim aDelProps
aDelProps = Array( "101e6622", "101e6623", "101e6624", "101f6627", "101f6628", "101f6629", "11026620", "11026626" )
For j=0 To UBound(aDelProps)
stdRegProv.DeleteValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, aDelProps(j)
Next
Exit For
End If
Next
'
Set stdRegProv = Nothing

選択したメッセージをファイル名に部署名をつけて MSG ファイルまたは RTF ファイルとして保存するマクロ

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


初めまして。仕事でOutlook2013を利用しています。(ExchangeServer2013環境だと思われます。)
日々、大量のメールが届くため、PC本体に受信メールを自動保存する方法がないかと思い、次のマクロを参考にさせてもらいました。
⇒2010年11月18日「選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロ
ファイル名として、送信者の部署名を入れたいのですが可能でしょうか。
これまでの問合せを見たところ、部署名はExchangeUserオブジェクトのDepartmentプロパティにあることはわかりましたが、どのように取得すればよいのか(取得可能なのかも含めて)わかりません。ご教授願います。



送信者の情報は MailItem の Sender プロパティで取得可能です。
そして、送信者の部署名については、Sender の GetExchangeUser メソッドで ExchangeUser オブジェクトを取得し、その Department プロパティにより参照可能です。
選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロをファイル名に部署名を入れるよう修正したものは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' MSG として保存するマクロ
Sub SaveSelectedItemsAsMSG()
    SaveSelectedItemsToDisk olMSGUnicode
End Sub
'
' RTF として保存するマクロ
Sub SaveSelectedItemsAsRTF()
    SaveSelectedItemsToDisk olRTF
End Sub
'
' 保存するマクロのメイン
Sub SaveSelectedItemsToDisk(saveAsType As OlSaveAsType)
    On Error Resume Next
    Const SAVE_PATH = "c:\temp\" ' 保存するフォルダのパス。最後に必ず \ をつける
    Dim objItem 'As MailItem
    Dim strDept As String
    Dim strFileName As String
    Dim i As Integer
    Dim arrErrChars
    Dim objFSO
    Dim strExt
    If saveAsType = olRTF Then
        strExt = ".rtf"
    Else
        strExt = ".msg"
    End If
    arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' 現在表示中のフォルダで選択されたアイテムについて
    For Each objItem In ActiveExplorer.Selection
        ' 差出人の部署名を取得
        strDept = ""
        If objItem.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
            strDept = objItem.Sender.GetExchangeUser().Department & "_"
        End If
        ' ファイル名を受信日時、部署名と件名から作成
        strFileName = Format(objItem.ReceivedTime, "yyyymmdd_hhnn_")
        If Err.Number <> 0 Then
            ' エラーが発生したら受信日時ではなく最終更新日時とする
            strFileName = Format(objItem.LastModificationTime, "yyyymmdd_hhnn_")
            Err.Clear
        End If
        strFileName = strFileName & strDept & objItem.SenderName & "_" & objItem.Subject
        ' ファイル名として不適切な文字を _ に置き換える
        For i = 0 To UBound(arrErrChars)
            strFileName = Replace(strFileName, arrErrChars(i), "_")
        Next
        ' ファイル名が 260 文字を超えないようにする
        strFileName = Left(SAVE_PATH & strFileName, 250)
        ' 同名のファイルがある場合の処理
        If objFSO.FileExists(strFileName & strExt) Then
            i = 2
            ' (2) から始める
            While objFSO.FileExists(strFileName & "(" & i & ")" & strExt)
                i = i + 1
            Wend
            strFileName = strFileName & "(" & i & ")"
        End If
        ' ファイルをフォルダに保存
        objItem.SaveAs strFileName & strExt, saveAsType
    Next
End Sub

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

受信した Excel ファイルを印刷するマクロ

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


outlook2010で2つのメールアドレスを使用しています。その片方のメールアドレスに届いたエクセルファイルだけ自動で印刷するということをしたいです。

このようなマクロを作成していただけないでしょうか?



2 つのメールアドレスを使用するというのが、以下のどちらのことを意味しているのかがちょっと分かりかねましたので、ルールで実行するマクロにしました。

  • 一つのアカウントに複数のメールアドレスが受信される
  • 二つのアカウントでそれぞれに受信される

以下のようなマクロを定義し、「受信者のアドレスに特定の文字が含まれる場合」や「指定されたアカウントを経由した場合」の条件で実行されるルールのアクションの「スクリプトを実行する」のスクリプトとして、PrintExcelAttach を指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                (ByVal hwnd As Long, ByVal lpszOp As String, _
                 ByVal lpszFile As String, ByVal lpszParams As String, _
                 ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                 As Long
'
Public Sub PrintExcelAttach(ByRef objItem As MailItem)
    On Error Resume Next
    Const ATTACH_PATH = "c:\temp\" ' 添付ファイルを保存するフォルダー
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer
    ' 添付ファイルの印刷
    Dim objFSO 'As FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objAttach In objItem.Attachments
        If objAttach.FileName Like "*.xls*" Then
            ' ファイルが Excel の場合のみ保存して印刷
            c = 1
            With objAttach
                strFileName = .FileName
                While objFSO.FileExists(ATTACH_PATH & strFileName)
                    strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                        & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                    c = c + 1
                Wend
                .SaveAsFile ATTACH_PATH & strFileName
            End With
            '    保存したファイルを印刷する
            ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
        End If
    Next
End Sub

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