【Outlook】メール本文の分断されたパスをワンクリック開く【マクロ】


©David Castillo Dominici

©David Castillo Dominici

このページで紹介するのは、、、

【さくっとフォルダを開く】

分断されたメール本文の
ディレクトリやパス名でもワンクリックで飛べる
Outlookマクロの紹介です。

背景・概要

メールにリンク先が書かれていても、改行されたり、引用されたりでExploreにコピペするのは面倒!
そこで、このマクロはワンクリックで そのパスらしきものを開きます。

機能

それっぽいパスを フォルダ(Explorer)か ブラウザで開く
例1:
http://www.google.com

例2:

<\\hogehoge\a-team\work\議題>

例3:

> > X:\hogehoge\a-tea
> > m\wor
> > k\議題
※元ディレクトリ名にスペースが入って、そこで改行されると少し見えなくなる。

もしヒットしない場合、スペースを削除したり親フォルダに移動させたりします。全てミスすると結局マイコンピューターっみたいなところを開くときもある。

 

機能を詳しく、デメリットなども含めて説明

・pathは始めに見つけたひとつのみ
  - <>で囲われた方を下の方にあっても優先して先にチェック
  - クリップボード非対応
  - 3行ぐらいなら頑張ってパスを拾ってみる。
・\\で始まるか、X:などのパスを検索
・URLは先頭がhttpの場合のみで、ヒットしていればブラウザで開く
・> > など引用で途切れていてもリカバリします。
・ファイルは直接開かず、今はディレクトリを開くようにひと手間かけていますので、直接ファイルを開きたい人はカスタマイズして下さい。

ディレクトリの次の行に\記号がなくファイル名が書かれていたり、補足情報があると3行以内であれば拾ってしまいます。そのため、マージされたそのディレクトリが無いと判断し、ひとつ上のディレクトリまでさかのぼります。

初回の設定

例によってOutlookのマクロエディターにコピペし、マクロ実行可能なセキュリティレベルにしておく。
さらに、クイックツールアクセスバーにマクロを設定すると便利。マクロ登録方法はこちら

ソース

github

Public Sub フォルダジャンプ()

    'MsgBox "folder jump start!"
    'Dim objMail As MailItem
    
    ' 本文を取得
    If TypeName(ActiveWindow) = "Explorer" Then
      FolderJump ActiveExplorer.Selection(1)
    Else
      FolderJump ActiveInspector.CurrentItem
    End If
End Sub

    
' それっぽいパスを フォルダ(Explorer)か ブラウザで開く
'   ・pathは始めに見つけたひとつのみ。
'      - <>で囲われた方を下の方にあっても優先して先にチェック
'      - クリップボード非対応
'      - 3行ぐらいなら頑張ってパスを拾ってみる。
'   ・\\で始まるか、X:などのパスを検索
'   ・URLは先頭がhttpの場合のみで、ヒットしていればブラウザで開く
Private Sub FolderJump(ByVal objMail As MailItem)
    Dim strBody As String
    Dim path As String
    Dim firstPath As String
    Dim pc As Integer  'path check
    Dim objFSO As Object ' FileSystemObject

    Dim re As RegExp
    Dim mc As MatchCollection
        
    strBody = objMail.Body
        
    'ざっくり引用符を置換  pathの途中に入っていることを懸念  "hiroshi wrote > >  hoge.html"
    Set re = New RegExp
    re.Pattern = "\n[ a-zA-Z0-9一-龠]*[  \t]*([$%>|#$%>|#][  \t]*){1,}"
    re.Global = True
    strBody = re.Replace(strBody, "") 'vbCR
    
    '上記とほぼ同様(1行目のケース)。
    re.Pattern = "^[ a-zA-Z0-9一-龠]*[  \t]*([$%>|#$%>|#][  \t]*){1,}"
    re.Global = True
    strBody = re.Replace(strBody, "")
    
    'strBody = Mid(strBody, 180, 200)
    'MsgBox strBody

    '一通り、パス、URLをチェックしてみる。
    pc = 1
    path = GetPathString(strBody, "[<<][  \t]*([^  \t>>\n@]{8,})\n?([^  \t>>\n@]+)?\n?([^  \t>>\n@]+\n)?([^  \t>>\n@]+)?[>>]") '4行ぐらい
    If path = "" Then
        pc = 2
        path = GetPathString(strBody, "[<<][  \t]*(\\\\[a-zA-Z0-9\.]{15,})([^  \t>>\n@]+)\n?([^  \t>>\n@]+\n)?([^  \t>>\n@]+)?[>>]")
    End If
    
    If path = "" Then
        pc = 8
        path = GetPathString(strBody, "[<<][  \t]*(https?://[\w/:%#\$&\?\(\)~\.=\+\-]+)\n?([\w/:%#\$&\?\(\)~\.=\+\-]+)?\n?([\w/:%#\$&\?\(\)~\.=\+\-]+)?[>>]")
        'path = GetPathString(strBody, "[<<](https?://[^\n>>]+)\n?([^\n>>]+)?\n?([^\n>>]+)?[>>]")
        'path = GetPathString(strBody, "[<<](https?://[\\\w/:%#\\\$&\\\?\\\(\\\)~\\\.=\\\+\\\-]+)\n?([\\\w/:%#\\\$&\\\?\\\(\\\)~\\\.=\\\+\\\-]+)?\n?([\\\w/:%#\\\$&\\\?\\\(\\\)~\\\.=\\\+\\\-]+)?[>>]")
    End If
            
    If path = "" Then
        pc = 11
        path = GetPathString(strBody, "^([A-Z]:)([^>\n]{8,})\n?([^>\n]+)?\n?([^>\n]+)?")
        If path = "" Then
            pc = 12
            path = GetPathString(strBody, "[  \t\b\n\r<<\""]+([A-Z]:)([^>>\n\""]{8,})\n?([^>>\n\""]+)?\n?([^>>\n\""]+)?")
        End If
        'If path = "" Then
        '    pc = 13
        '    path = GetPathString(strBody, "([A-Z]:)([^>>\n\""]{8,})\n?([^>>\n\""]+)?\n?([^>>\n\""]+)?")
        'End If
    End If
    
    If path = "" Then
        pc = 15
        path = GetPathString(strBody, "(\\\\[a-zA-Z0-9\.]{8,})([^>\n]+)\n?([^>\n]+)?\n?([^>\n]+)?")
    End If
    
    If path = "" Then
        pc = 18
        path = GetPathString(strBody, "(https?://[\w/:%#\$&\?\(\)~\.=\+\-]+)\n?([\w/:%#\$&\?\(\)~\.=\+\-]+)?\n?([\w/:%#\$&\?\(\)~\.=\+\-]+)?")
    End If
        
    If path = "" Then
        pc = 0
    End If
   'MsgBox "got path(" & pc & "): [" & path & "]"
   
   '文字列ヒットしていたらジャンプする
   If path <> "" Then

        '空行以降はカット
        re.Pattern = "[\r\n]{2,}.+"
        path = re.Replace(path, "")
        
        '改行部分はくっつける
        re.Pattern = "[\r\n]"
        re.Global = True
        path = re.Replace(path, "")
        
        'ShellExecute (path)
        'MsgBox "origin path [" & path & "]"

        If Left(path, 4) = "http" Then
            retval = Shell("C:\Program Files\Google\Chrome\Application\chrome.exe" & " " & path, vbNormalFocus)
            'retval = Shell("C:\Program Files\Internet Explorer\IEXPLORE.EXE" & " " & path, vbNormalFocus)
        Else

           'MsgBox "origin path " & path
           Set objFSO = CreateObject("Scripting.FileSystemObject")
           If objFSO.FolderExists(path) = False And path <> "" Then
               firstPath = path
           End If
           
           While objFSO.FolderExists(path) = False And path <> ""
                'ためしに spaceを削除してみる。
                re.Pattern = "[  \t]"
                path2 = re.Replace(path, "")
                If (objFSO.FolderExists(path2) = True) Then
                    path = path2
                Else
                    '上位フォルダへ
                    path = objFSO.GetParentFolderName(path)
                    'MsgBox "up dir " & path
                End If
                
           Wend

        If Len(firstPath) > 3 Then
           MsgBox "not perfect match: " & vbCrLf & firstPath & vbCrLf & "  ↓   ↓   " & vbCrLf & path & "  (to opened)"
        End If

            retval = Shell("C:\Windows\explorer.exe" & " " & path, vbNormalFocus)
        ' vbNormalFocus :1 = focusを遷移させる。
        End If
        
        If retval = 0 Then
           MsgBox "起動に失敗しました。"
        Else
           'MsgBox "起動成功:" & retval
        End If
   
   Else
       MsgBox "path or url was't hit..." & vbCrLf & "-----" & vbCrLf & path
   End If
End Sub

' 本文から特定の情報を取得する関数
Private Function GetPathString(strBody As String, regpattern As String)
    Dim re As RegExp
    Dim mc As MatchCollection
        
    Set re = New RegExp
    re.Pattern = regpattern
    Set mc = re.Execute(strBody)

    If mc.Count = 0 Then
      GetPathString = ""
    Else
      GetPathString = mc(0).SubMatches(0)
      For i = 1 To mc(0).SubMatches.Count - 1
        GetPathString = GetPathString & mc(0).SubMatches(i)
      Next
    End If

End Function

関連ページリンク

【仕事で残念な人にならないために】Outlookメール誤送信チェックマクロ【冷汗防止】

【作業効率化】メール本文からスケジュール登録をワンクリックで行うマクロ[outlook]【おすすめ】

Outlookでの仕事効率技5連発!

Delicious にシェア
Digg にシェア
reddit にシェア
LinkedIn にシェア
LINEで送る
email this
Pocket

2,065 views.



コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です