メールのスレッドを保持してExcelにエクスポートするマクロ (エイリアス バージョン)

メールのスレッドを保持してExcelにエクスポートするマクロのコメントにて以下のご要望をいただきました。


大変便利なマクロを披露していただき、ありがとうございます。
自分が使用している環境では、宛先、Cc、差出人がすべて「表示名」で表示され->Excelの表にも表示名で記入されます。
この表示名をエイリアスの表示に切り替えるにはどうすればよいでしょうか。

よろしくご教示ください


エイリアス、ということは Exchange サーバー環境でしょうか?
その場合、差出人や受信者のオブジェクトで GetExchangeUser などにより Exchange 情報を取得する必要があります。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Option Explicit
' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportToExcelWithThread()
    On Error Resume Next
    Dim appExcel 'As Excel.Application
    Dim objBook 'As Excel.Workbook
    Dim objSheet 'As Excel.Worksheet
    Dim bConvOK As Boolean
    Dim colItems As Items
    Dim objItem 'As MailItem
    Dim c As Integer
    '
    Set appExcel = CreateObject("Excel.Application")
    Set objBook = appExcel.Workbooks.Add()
    Set objSheet = objBook.Sheets(1)
    With objSheet
        .Cells(1, 1) = "スレッド情報"
        .Cells(1, 2) = "日付"
        .Cells(1, 3) = "宛先"
        .Cells(1, 4) = "Cc"
        .Cells(1, 5) = "差出人"
        .Cells(1, 6) = "件名"
        .Cells(1, 7) = "本文"
    '
        Set colItems = ActiveExplorer.CurrentFolder.Items
        colItems.Sort "送信日時"
        bConvOK = ActiveExplorer.CurrentFolder.Store.IsConversationEnabled
        For Each objItem In colItems
            If bConvOK Then
                ExportThreadByConversation objItem, objSheet
            Else
                ExportThreadByMessageId objItem, objSheet
            End If
        Next
        For c = 2 To .UsedRange.Columns.Count Step 6
            .Cells(1, c) = "日付"
            .Cells(1, c + 1) = "宛先"
            .Cells(1, c + 2) = "Cc"
            .Cells(1, c + 3) = "差出人"
            .Cells(1, c + 4) = "件名"
            .Cells(1, c + 5) = "本文"
        Next
    End With
    '
    appExcel.Visible = True
    objBook.Windows(1).Visible = True
End Sub
'
Private Sub ExportThreadByConversation(objItem, objSheet)
    Const PR_CONVERSATION_ID = "http://schemas.microsoft.com/mapi/proptag/0x30130102"
    Dim strConvID As String
    Dim r As Integer
    Dim c As Integer
    '
    With objItem.PropertyAccessor
        strConvID = .BinaryToString(.GetProperty(PR_CONVERSATION_ID))
    End With
    r = 2
    While objSheet.Cells(r, 1) <> ""
        If objSheet.Cells(r, 1) = strConvID Then
            Exit Sub
        End If
        r = r + 1
    Wend
    objSheet.Cells(r, 1) = strConvID
    c = 2
    EnumConversation objItem.GetConversation().GetRootItems, objSheet, r, c
End Sub
'
Private Sub EnumConversation(colItems As SimpleItems, objSheet, r As Integer, c As Integer)
    Dim objItem 'As MailItem
    Dim conv As Conversation
    Dim colSubItems As SimpleItems
    For Each objItem In colItems
        WriteCell objItem, objSheet, r, c
        c = c + 6
        Set conv = objItem.GetConversation()
        Set colSubItems = conv.GetChildren(objItem)
        If colSubItems.Count > 0 Then
            EnumConversation colSubItems, objSheet, r, c
        End If
    Next
End Sub
'
Private Sub ExportThreadByMessageId(objItem, objSheet)
    Const PR_INTERNET_MESSAGE_ID = "http://schemas.microsoft.com/mapi/proptag/0x1035001e"
    Const PR_IN_REPLY_TO_ID = "http://schemas.microsoft.com/mapi/proptag/0x1042001e"
    Dim strMsgID As String
    Dim strRepID As String
    Dim r As Integer
    Dim c As Integer
    Dim bFound As Boolean
    '
    With objItem.PropertyAccessor
        strMsgID = .GetProperty(PR_INTERNET_MESSAGE_ID)
        strRepID = .GetProperty(PR_IN_REPLY_TO_ID)
    End With
    '
    With objSheet
        c = 2
        If strRepID = "" Then
            r = .UsedRange.Rows.Count + 1
        Else
            bFound = False
            r = 2
            While (Not bFound) And .Cells(r, 1) <> ""
                If InStr(.Cells(r, 1), strRepID) > 0 Then
                    While .Cells(r, c) <> ""
                        c = c + 6
                    Wend
                    bFound = True
                Else
                    r = r + 1
                End If
            Wend
        End If
        .Cells(r, 1) = .Cells(r, 1) & strMsgID
        WriteCell objItem, objSheet, r, c
    End With
End Sub
'
Private Sub WriteCell(objItem, objSheet, r As Integer, c As Integer)
    On Error Resume Next
    With objSheet
        .Cells(r, c) = objItem.SentOn
        .Cells(r, c + 1) = GetRecipAliases(objItem, olTo)
        .Cells(r, c + 2) = GetRecipAliases(objItem, olCC)
        .Cells(r, c + 3) = GetAlias(objItem.Sender)
        .Cells(r, c + 4) = objItem.Subject
        .Cells(r, c + 5) = objItem.Body
    End With
End Sub
'
Private Function GetRecipAliases(objItem, iType As OlMailRecipientType)
    Dim strAliases As String
    Dim objRecip As Recipient
    strAliases = ""
    For Each objRecip In objItem.Recipients
        If objRecip.Type = iType Then
            strAliases = strAliases & GetAlias(objRecip.AddressEntry) & ";"
        End If
    Next
    If strAliases <> "" Then
        strAliases = Left(strAliases, Len(strAliases) - 1)
    End If
    GetRecipAliases = strAliases
End Function
'
Private Function GetAlias(addrEntry As AddressEntry)
    On Error Resume Next
    Dim exchUser As ExchangeUser
    Dim exchDl As ExchangeDistributionList
    Dim strAlias As String
    Set exchUser = addrEntry.GetExchangeUser()
    Set exchDl = addrEntry.GetExchangeDistributionList()
    If Not exchUser Is Nothing Then
        strAlias = exchUser.Alias
    ElseIf Not exchDl Is Nothing Then
        strAlias = exchDl.Alias
    Else
        strAlias = addrEntry.Address
    End If
    GetAlias = strAlias
End Function

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

スレッドを保ったまま任意の文字列を件名のプレフィックスにつけて返信するマクロ

スレッドを保ったまま任意の文字列を件名につけて返信するマクロのコメントにて以下のご要望をいただきました。


このマクロを使って、件名を追加してもスレッド表示することが出来る様になりました。
が、このメールに返信すると、追加した部分が削除されてしまいます。
下記のように使用したいため、返信の際に追加した件名を残したいです。
なにか方法はありますか?

現状 Aさん テスト送信
Bさん 【最終回答】: テスト送信(マクロ)
Cさん Re:テスト送信

理想 Aさん テスト送信
Bさん 【最終回答】: テスト送信(マクロ)
Cさん 【確認】【最終回答】: テスト送信


元のマクロで件名に追加した文字列は、Outlook では PR_SUBJECT_PREFIX というプロパティに格納されます。
そのため、追加した文字列にさらに別の文字列を追加する場合、元のメールの PR_SUBJECT_PREFIX を取得し、それに別の文字列を追加するという動作が必要になります。
これについては以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
' OK をつけるマクロ
Public Sub AppendLastPrefix()
    AppendPrefix "【最終回答】"
End Sub
' NG をつけるマクロ
Public Sub AppendConfirmPrefix()
    AppendPrefix "【確認】"
End Sub
' 任意の文字列を入力して付与するマクロ
Public Sub AppendAnyPrefix()
    Dim strPrefix As String
    strPrefix = InputBox("付与する文字列:")
    If strPrefix <> "" Then
        AppendPrefix strPrefix
    End If
End Sub
' 文字列を件名のプレフィックスに追加するサブプロシージャ
Private Sub AppendPrefix(strPrefix As String)
    Const PR_SUBJECT_PREFIX = "http://schemas.microsoft.com/mapi/proptag/0x003d001f"
    Dim strOrgPrefix As String
    Dim objAction As Action
    Dim objItem As MailItem
    Dim objReply As MailItem
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        Set objItem = ActiveInspector.CurrentItem
    Else
        Set objItem = ActiveExplorer.Selection(1)
    End If
    ' 元のメールの件名のプレフィックスを取得
    strOrgPrefix = objItem.PropertyAccessor.GetProperty(PR_SUBJECT_PREFIX)
    ' プレフィックスについている : を削除
    If Right(strOrgPrefix, 2) = ": " Then
        strOrgPrefix = Left(strOrgPrefix, Len(strOrgPrefix) - 2)
    End If
    Set objAction = objItem.Actions.Add
    objAction.Name = strPrefix & strOrgPrefix
    objAction.Prefix = strPrefix & strOrgPrefix
    objAction.ReplyStyle = olUserPreference
    objAction.ShowOn = olDontShow
    Set objReply = objAction.Execute
    objReply.Display
    objItem.Save
End Sub

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

メールの本文で選択されたキーワードを Web で検索するマクロ

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


メールの本文など、あるキーワードを選択した状態で、

右クリック->Google検索(マクロ)->ブラウザが起動(googleサイトで検索)

となるようなマクロは作成できませんでしょうか?


マクロで本文の右クリックで表示されるメニュー (コンテキスト メニュー) を追加するのは困難なので、本文で選択した文字列を検索するマクロにしました。

' ここをトリプルクリックでマクロ全体を選択できます。
' Google 検索を行うマクロ
Public Sub GoogleSearch()
    WebSearch "https://www.google.co.jp/search?q="
End Sub
' Bing 検索を行うマクロ
Public Sub BingSearch()
    WebSearch "https://www.bing.com/search?q="
End Sub
' Wikipedia 検索を行うマクロ
Public Sub WikipediaSearch()
    WebSearch "https://ja.wikipedia.org/wiki/"
End Sub
' 検索を実行する共通マクロ
Private Sub WebSearch(strCmd As String)
    Dim objDoc As Object ' Word.Document
    Dim strKey As String
    Dim objShell As Object
    ' 選択された文字列を取得
    Set objDoc = ActiveInspector.WordEditor
    strKey = Trim(objDoc.Application.Selection.Text)
    strKey = Replace(strKey, " ", "%20")
    ' 取得した文字列を引数に追加して実行
    Set objShell = CreateObject("WScript.Shell")
    objShell.Run strCmd & strKey
End Sub

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

前の月に受信したメールのうち、特定のキーワードを含むメールをカウントするマクロ

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


マクロ作成について、ご教示ください。
outlook2013を使用しています。
ある特定の期間に受信したメールのうち、
件名に特定のキーワードが入っているメールをカウントし、
件数とその件名を抽出したいと思っています。
また、今日を基準に、先月を自動算出し、
先月分の条件に該当するメールをカウントするなどは可能でしょうか。
よろしくお願いします。


以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub FindMailByKeywordLastMonth()
    On Error Resume Next
    ' 検索するキーワードを指定
    Const SEARCH_KEY = "test"
    ' レポートを作成するファイルのフルパスを指定
    Const REPORT_FILE = "c:\temp\report.txt"
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim colItems As Items
    Dim objItem As Object
    Dim cntItems As Integer
    Dim strReport As String
    ' 前月を表す日付範囲を算出
    dtEnd = Year(Now) & "/" & Month(Now) & "/1"
    dtStart = DateAdd("m", -1, dtEnd)
    ' 日付範囲でフィルタリング
    Set colItems = Session.GetDefaultFolder(olFolderInbox).Items
    colItems.Restrict "[受信日時] >= #" & dtStart & "# AND " & _
        "[受信日時] <  #" & dtEnd & "#"
    cntItems = 0
    strReport = ""
    ' フィルタリングしたメールを確認
    For Each objItem In colItems
        ' 件名にキーワードを含む場合はカウンタとレポート追加
        If InStr(objItem.Subject, SEARCH_KEY) > 0 Then
            cntItems = cntItems + 1
            strReport = strReport & objItem.ReceivedTime & vbTab & objItem.Subject & vbCrLf
        End If
    Next
    ' レポート作成
    Open REPORT_FILE For Output As #1
    Print #1, SEARCH_KEY & "を含むメールの件数:", cntItems
    Print #1, strReport
    Close #1
    ' レポートをメモ帳で表示
    Shell "notepad.exe " & REPORT_FILE
End Sub

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

場所から自動的に会議室メールボックスを宛先に追加するマクロ

Exchange サーバー環境では会議室のためのメールボックスを作り、会議出席依頼で会議室の予約を行うことができます。
また、会議室のメールボックスをリソースとして宛先に追加すると、同時に会議アイテムの [場所] にその会議室が設定されます。
この機能は非常に便利なのですが、ちょっと厄介なのが [場所] の履歴に会議室が残るという点です。
[場所] フィールドの右にはドロップダウンがあり、過去に使用した場所を選択することができるのですが、以前送信した会議室のメールボックスを指定しても宛先には自動では含まれません。
そのため、[場所] で会議室を選択した後、改めて会議室をリソースとして宛先に追加しなおす必要があるのです。
この操作を忘れて会議室を予約し忘れるということが発生しがちなので、場所に設定した会議室を宛先に追加し忘れていた場合に、自動で設定するマクロを作ってみました。
以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeName(Item) = "MeetingItem" Then
        ReplaceLocationToResource Item
    End If
End Sub
'
Private Sub ReplaceLocationToResource(ByVal meetItem As MeetingItem)
    Const PR_DISPLAY_TYPE_EX = "http://schemas.microsoft.com/mapi/proptag/0x39050003"
    Const DT_ROOM = 7
    Dim apptItem As AppointmentItem
    Dim resRecip As Recipient
    Dim bDelete As Boolean
    '
    Set apptItem = meetItem.GetAssociatedAppointment(False)
    If InStr(apptItem.Resources, apptItem.Location) > 0 Then
        Exit Sub    ' すでにリソースに登録済みなら終了
    End If
    Set resRecip = meetItem.Recipients.Add("=" & apptItem.Location)
    bDelete = True
    resRecip.Resolve
    If resRecip.Resolved Then
        If resRecip.AddressEntry.Type = "EX" Then
            If resRecip.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
                Dim exchUser As ExchangeUser
                Set exchUser = resRecip.AddressEntry.GetExchangeUser
                If exchUser.PropertyAccessor.GetProperty(PR_DISPLAY_TYPE_EX) = DT_ROOM Then
                    bDelete = False
                End If
            End If
        End If
    End If
    '
    If bDelete Then
        resRecip.Delete
    Else
        resRecip.Type = olResource
        Set resRecip = apptItem.Recipients.Add("=" & apptItem.Location)
        resRecip.Resolve
        resRecip.Type = olResource
        apptItem.Save
    End If
End Sub

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

決まった件名で終わるメッセージを受信したら、キーワードを含む 1 行を CSV ファイルに保存するマクロ

決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロのコメントにて以下のご要望をいただきました。


横から失礼します。
本件に近い操作をしたいと考えています。
1.一定の文言が含まれるメールが対象
2.対象としたメール本文から、対象となる文言が含まれる部分(1行)を抜き出し、CSV化
具体的には
1.件名:「~を入力しました。」 ※「~」は、都度 異なります。
2.本文:「●:●● ■■会議 予約済」 →この「予約済」を対象として、その1行を抜き出してCSV化で一覧にしたいと思っています。
このような操作は可能でしょうか?また、どのように設定すれば良いでしょうか?
ご教示、お願い致します。
※初心者につき、説明がわかりにくいようでしたら すみません。

12で質問させていただいた内容に追記させてください。
受信時間と件名もCSVに記載したいです。
まとめると・・・
1.件名の「~を入力しました」をKeyにして
2.件名(フル)と受信時間+本文の一部(●:●● ■■会議 予約済 ←「予約済」をKeyに1行を抜き出す)をCSV化
したいです。
ご教示、よろしくお願いします。


変更点は以下の 2 になります。

  • 件名の先頭部分は可変
  • キーワードを含む 1 行を抽出

件名の一部が一致するという条件を指定する場合は LIKE という演算子を使用します。
例えば、「~を入力しました。」の「~」が可変なのであれば、以下のような条件定義になります。
    If myMsg.Subject Like "*を入力しました。"  Then

また、1 行を抜き出すというのは、言い換えると「キーワードの前後の改行を検索し、その間の文字列を取得する」ということになります。

まとめると、以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    SaveLineToCsv EntryIDCollection
End Sub
'
Private Sub SaveLineToCsv(ByVal EntryIDCollection As String)
    Const AUTO_SAVE_TITLE_SUFFIX = "を入力しました。" ' 自動処理するメールの件名の終わりの文字
    Const CSV_FILE = "c:\temp\data.csv" ' データを保存する CSV ファイルの名前
    Const SEARCH_KEY = "予約済み" ' 本文で検索するキーワード
    Dim i As Integer
    Dim arrEntryId
    Dim myMsg
    Dim stmCsv
    Set stmCsv = Nothing
    arrEntryId = Split(EntryIDCollection, ",")
    For i = LBound(arrEntryId) To UBound(arrEntryId)
        Set myMsg = Application.Session.GetItemFromID(arrEntryId(i))
        If myMsg.Subject Like "*" & AUTO_SAVE_TITLE_SUFFIX Then
            Dim s As Integer
            Dim e As Integer
            Dim strLine As String
            If stmCsv Is Nothing Then
                Dim objFSO
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set stmCsv = objFSO.OpenTextFile(CSV_FILE, 8, True, 0)
            End If
            ' キーワードを本文から検索
            e = InStr(myMsg.Body, SEARCY_KEY)
            If e > 0 Then ' キーワードを含む場合だけ処理
                ' キーワードを含む行の最初 (=直前の行の改行) を検索
                s = InStrRev(myMsg.Body, vbLf, e)
                If s = 0 Then
                    s = 1 ' 改行がなければ本文の先頭から
                End If
                e = InStr(e, myMsg.Body, vbCr)
                'キーワードを含む行の終わりを取得
                If e = 0 Then
                    e = Len(myMsg.Body)
                End If
                ' キーワードを含む行を取得
                strLine = Mid(myMsg.Body, s, e - s)
                strLine = Replace(strLine, vbCr, "")
                strLine = Replace(strLine, vbLf, "")
                stmCsv.WriteLine myMsg.Subject & "," & myMsg.ReceivedTime & "," & strLine
            End If
        End If
    Next
    If Not stmCsv Is Nothing Then
        stmCsv.Close
    End If
End Sub

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

本文から取得したデータを項目別に 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

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