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

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


お世話になります。
仕事で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") & _

選択したメッセージをファイル名に部署名をつけて 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

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

仕訳ルールでメールの本文と PDF のみ印刷するマクロ

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


毎回、こちらのサイトにとてもお世話になっております。どうしてもお力添えいただきたく質問させていただきました。
・ 仕様環境 Win10(32bit) OUTLOOK2010
マクロは使用せず、仕分けルールと印刷設定を利用しまして、メールを受信したら添付ファイルごと自動で全て印刷をしております。
この際、【メール本文+PDF】は印刷したいのですが、それ以外の添付ファイル(doc、docx、xls、xlsx、ppt、pptx、zip、csv、exe 等)は印刷しないで無視するように設定できないものか苦慮しております。
このような都合の良いマクロを作りたいと考えているのですが、何か良い方法はございますでしょうか。


ルールの指定では特定の種類のファイルだけ印刷しないというようなことはできないので、本文の印刷と添付ファイルが pdf のときだけ保存して印刷をするというマクロを作成し、それをルールの条件として呼び出すことでご要望の動作ができると思います。
以下のマクロを設定し、ルールの条件で [スクリプト] としてマクロの名前を指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
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 PrintBodyAndPDFAttach(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
    ' 本文を印刷
    objItem.PrintOut
    ' 添付ファイルの印刷
    Dim objFSO 'As FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objAttach In objItem.Attachments
        If objAttach.FileName Like "*.pdf" Then
            ' ファイルが PDF の場合のみ保存して印刷
            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

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

深い階層のフォルダーを一度に作成するマクロ

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


お世話になっております。Outlook 2013 または 2016 で、受信トレイのサブフォルダーとして作成したフォルダー A に対して、さらに多階層のサブフォルダーを一括作成したいと考えています。
具体的には、フォルダー A のサブフォルダーとしてサブフォルダー B を、そして、サブフォルダー B のサブフォルダーとしてさらにサブフォルダー C を、、、という感じで、3~4 階層程度のサブフォルダーを作成する方法をご教示くださいますようお願いいたします。
よろしくお願いします。


Outlook の標準機能ではフォルダーは 1 度に 1 つしか作れないため、ご要望のような動作を満たすにはマクロを作る必要があります。
例えば、現在選択中のフォルダーの下に、入力した文字列を ¥ で区切ったフォルダー階層を作成するマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CreateDeepSubFolder()
    On Error Resume Next
    Dim fldRoot As Folder
    Dim fldSub As Folder
    Dim strPath As String
    Dim astrFolders As Variant
    Dim strSub As Variant
    '
    strPath = InputBox("フォルダー パス")
    If strPath <> "" Then
        astrFolders = Split(strPath, "¥")
        Set fldRoot = ActiveExplorer.CurrentFolder
        For Each strSub In astrFolders
            Set fldSub = Nothing
            Set fldSub = fldRoot.Folders(strSub)
            If fldSub Is Nothing Then
                Set fldSub = fldRoot.Folders.Add(strSub)
            End If
            Set fldRoot = fldSub
        Next
    End If
End Sub

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

会議出席依頼にフラグを付けるマクロ

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


Outlook2010 で会議出席依頼(MeetingItem)を受信した時に、フラグを付ける(開始日は受信日、期限は会議の日)マクロを作りたいのですが、どうすればよいのでしょうか?


Outlook Object モデルの MeetingItem にはフラグを設定するためのメソッドやプロパティが用意されていません。
そのため、MeetingItem にフラグを付けるには、PropertyAccessor.SetProperty によりいくつかの MAPI プロパティを設定する必要があります。
ご要望のマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem As Variant
    Set objItem = Session.GetItemFromID(EntryIDCollection)
   
    If TypeName(objItem) = "MeetingItem" Then
        SetStartAndDueDate objItem
    End If
End Sub
'
Private Sub SetStartAndDueDate(ByVal meetItem As MeetingItem)
    Const PidLidToDoTitle = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/85A4001E"
    Const PidLidTaskStartDate = "http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81040040"
    Const PidLidTaskDueDate = "http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81050040"
    Const PidLidReminderSet = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8503000B"
    Const PR_TODO_ITEM_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x0E2B0003&quot;
    With meetItem.PropertyAccessor
        .SetProperty PidLidToDoTitle, meetItem.Subject
        .SetProperty PidLidTaskStartDate, Now
        .SetProperty PidLidTaskDueDate, meetItem.GetAssociatedAppointment(False).Start
        .SetProperty PidLidReminderSet, True
        .SetProperty PR_TODO_ITEM_FLAGS, 1
    End With
    meetItem.Save
End Sub

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