20191021_Outlookでメール受信者がローカルパスをクリックできるようにするマクロ

outlook_path_hyperlink.vba

Rem --------------------------------------------------
Rem ■Outlookでメール受信者がローカルパスをクリックできるようにするマクロ
Rem
Rem  えくせるちゅんちゅん
Rem  2019/10/21
Rem  https://www.excel-chunchun.com/entry/outlook-path-hyperlink
Rem
Rem --------------------------------------------------

Option Explicit

Sub メール作成画面のパスをハイパーリンクに変換()
    Dim objItem As Outlook.MailItem
    Set objItem = ActiveInspector.CurrentItem
    objItem.body = ReplacePathToHyperlink(objItem.body)
End Sub

Rem --------------------------------------------------
Rem ■kccFuncString
Rem  文字列変換関数
Rem --------------------------------------------------
Rem
Rem 抜粋
Rem
Rem --------------------------------------------------

Rem 文章中のパスと思われる文字列をハイパーリンクに対応させる関数
Rem
Rem  @param base_str       変換元文字列
Rem
Rem  @return  As string    ハイパーリンク化された文字列
Rem
Rem  @example
Rem    IN :
Rem         おつかれさまです
Rem         C:\Test\hoge.xls
Rem         以上､よろしくおねがいします｡
Rem   OUT :
Rem         おつかれさまです
Rem         <"file://C:\Test\hoge.xls">
Rem         以上､よろしくおねがいします｡
Rem
Rem  @note
Rem        パスは <"file:// "> で囲うことでハイパーリンク化される。
Rem        条件：必ずパスは改行で終わること
Rem        Outlookではメール送信時の自動折返しを切っておくこと
Rem        メール作成画面ではリンク状態にはならない。
Rem        自分から自分へ送信してテストするように。
Rem
Function ReplacePathToHyperlink(base_str As String) As String
    Dim pathIdx: pathIdx = 1
    Dim lfIdx: lfIdx = 1
    Dim pathData
    Dim v
    Dim i As Long
    Dim s As String

    Dim pathHeader As String

    '改行(CRLF)をパス終了とみなす
    Dim base_str_arr
    base_str_arr = Split(base_str, vbCrLf)

    'UNCパスの変換
    Dim uncArr '.0~.255    '.16~.31
    uncArr = Array("\\127.0.0.1", "\\10.", "\\172.", "\\192.168.")

    For i = LBound(base_str_arr) To UBound(base_str_arr)
        s = base_str_arr(i)

        'パスと思われる文章を検索
        For Each v In uncArr
            pathIdx = InStr(lfIdx, s, "" & v)
            If pathIdx > 0 Then Exit For
        Next

        'UNCパスを<"UNCパス">に変換
        If pathIdx > 0 Then
            pathData = Mid(s, pathIdx, 9999)
            s = Replace(s, pathData, "<""" & pathHeader & pathData & """>")
            base_str_arr(i) = s
        End If
    Next

    'ドライブレター付きパスの変換
    Dim pathArr(1 To 26)
    For i = 1 To 26: pathArr(i) = Chr(Asc("A") - 1 + i) & ":\": Next

    For i = LBound(base_str_arr) To UBound(base_str_arr)
        s = base_str_arr(i)

        'パスと思われる文章を検索
        For Each v In pathArr
            pathIdx = InStr(lfIdx, s, "file://" & v)
            If pathIdx > 0 Then Exit For
        Next
        If pathIdx <= 0 Then
            For Each v In pathArr
                pathIdx = InStr(lfIdx, s, v)
                If pathIdx > 0 Then Exit For
            Next
            pathHeader = "file://"
        Else
            pathHeader = ""
        End If

        'パスを<"\\パス">に変換
        If pathIdx > 0 Then
            pathData = Mid(s, pathIdx, 9999)
            s = Replace(s, pathData, "<""" & pathHeader & pathData & """>")
            base_str_arr(i) = s
        End If
    Next

    '既に付与されていた場合の二重付与を解除
    For i = LBound(base_str_arr) To UBound(base_str_arr)
        s = base_str_arr(i)
        s = Replace(s, "<""<""", "<""")
        s = Replace(s, """>"">", """>")
        s = Replace(s, """<""", "<""")
        s = Replace(s, """"">", """>")
        base_str_arr(i) = s
    Next

    ReplacePathToHyperlink = Join(base_str_arr, vbCrLf)
End Function