OUTLOOK Word VBA URL,現在編集中のウィンド(Inspector)にファイル、フォルダのリンクを文末に挿入するマクロ

OUTLOOKでメールを編集する画面をインスペクターと言います。
インスペクターにはURLを入れる機能はありますが、使い勝手がよくありません。
そこで文末に入れる機能を作りました。

注意点

署名の前を判定させる

文末とはここでは署名の前のことをいいます。
署名の前をどうやって判定させるか。
これは個人の署名の仕様次第ですが、たとえばこんな感じの署名だったとします。

-From---
Mail:Qitta@doress
Name:

--

といった署名だとします。そうすると文末とは-from---のまえだとわかります。
これを検索して判定します。なのでリプライが重なり、署名がなんども出てくるとうまくいかないです。なお、インスペクターを立ち上げた後、署名を挿入するには三流君の方法しかないようです。

Wordが必要

このVBAはWordの機能を使っています。（参照設定もしますが）

改行が入る

成功するとなぜか改行が入りますが、削ってください。

InsertURLAndFileLinkToActiveMailInspector

Sub InsertURLAndFileLinkToActiveMailInspector()
'For OUTLOOK VBA
'You must add a reference to the Microsoft Word and FSO and regExp Object Library
'before this sample will compile
'WordとFilesystemObject、VbScript Regular Expression 5.5を参照設定してください
Dim MyItem As Outlook.MailItem
Dim AIN As Outlook.Inspector
Dim wdDoc As Word.Document
Dim wdRange As Word.Range, wdRng2 As Word.Range
Dim objItem
Dim str As String
Dim buf As String, bu1 As String, bu2 As String, bu3 As String
Dim obj As Object
Dim iPosition As Long
Dim NS As NameSpace: Set NS = Outlook.Session
Dim ss: Set ss = Outlook.Session
Dim fs As FileSystemObject: Set fs = New Scripting.FileSystemObject
Dim REX As RegExp: Set REX = New RegExp
Dim isURL As Boolean: isURL = False
Dim wdFound As Word.Find
buf = InputBox("Input File or Folder Name", "Input")
On Error Resume Next
If fs.FileExists(buf) Then
Set obj = fs.GetFile(buf)
ElseIf fs.FolderExists(buf) Then
Set obj = fs.GetFolder(buf)
Err.Clear
End If
With REX
.Global = True
.MultiLine = False
.IgnoreCase = False
.Pattern = "^(http*|ftp|www)" '文字列の先頭がhttp(s),ftp,wwwのときURLと判定する
If .test(buf) = False Then
If obj Is Nothing Then Exit Sub
Else
isURL = True
End If
End With
'ActiveInspectorからCurrentItem
Set AIN = ActiveInspector
Set objItem = AIN.CurrentItem
Set MyItem = objItem
If Err.Number <> 0 Then Exit Sub
str = objItem.Body
iPosition = InStrRev(str, "-From---", -1, vbTextCompare)
bu1 = Mid(str, 1, iPosition - 1)
bu2 = Mid(str, iPosition, Len(str) - iPosition)
str = ""
If isURL = False Then
str = Replace(bu1, " ", "", 1, -1, vbTextCompare) & " <File:///" & Replace(obj.Path, "\", "/", 1, -1) & "> " & vbCrLf & bu2
bu3 = "<File:///" & Replace(obj.Path, "\", "/", 1, -1) & ">" & vbCrLf
Else
str = Replace(bu1, " ", "", 1, -1, vbTextCompare) & " <" & buf & "> " & vbCrLf & bu2
bu3 = " <" & buf & "> "
End If
' objItem.Body = ""
' objItem.Body = str
'-----
'Find And Insert
Set wdDoc = AIN.WordEditor
If Not (wdDoc Is Nothing) Then
wdDoc.Activate
Set wdRange = wdDoc.Range(Start:=wdDoc.Characters(1).Start, End:=wdDoc.Characters(wdDoc.Characters.Count).End)
With wdRange.Find
.ClearFormatting
.Execute findText:="-from---", MatchCase:=True, MatchWholeWord:=True, MatchWildcards:=False, Forward:=False, Format:=False
If .Found Then Set wdFound = wdRange.Find: Set wdRng2 = wdRange: wdRng2.Move , -1
wdRng2.InsertBefore bu3 & vbCrLf
End With
End If
End Sub