[vba vbs cmd tool] 【超便利ツール自作】リンク付きで指定パス配下にある指定対象のみExcelへPrint

超便利ツール

ファイルパスをExcelで出力させる同時にハイパーリンク付きにどうやって？
やり方は簡単！以下のコードをそのままコピーしておけば完成。

特徴

・超便利なカスタマイズ
　※cmdのdir,findに詳しければ、もっと便利になる
・cmd命令は自由自在（何でも実行結果の出力ができる）
・超簡単な使い方
・単純すぎる仕組み
　※Copyだけですぐ使える
・拡張性抜群（一時ファイル利用）

Private Sub CommandButton1_Click()
    Call CreateDir
End Sub

Private Sub CreateDir()
Const TMPFNM = "_tmpdirf_"
    Dim path As String
    path = Trimmer(Trim(GetTextFromClipboard()))
    Dim cmd, inputcmd As String
    Dim tree As String
    Dim filedata() As String
    Dim tmpFilenm As String
    Dim selectHere As Object
    Set selectHere = Selection
    tmpFilenm = TMPFNM & GetNow_yyyyMMddHHmmss() & ".txt"
On Error GoTo EXECEPTION
    If path = "" Then
        MsgBox vbCrLf & "対象ルートパスをシステムクリップボードにCopyしておいた上、" & vbCrLf & "再度実行してください" & vbCrLf, vbExclamation, "※実行前提確認"
        Exit Sub
    Else
        inputcmd = InputBox("以下は説明とよく使いそうなオプション" & vbCrLf & _
             "・/s サブディレクトリも含めた全てのファイル情報を表示" & Chr(13) & _
             "・/b ディレクトリ名とファイル名のみを表示" & Chr(13) & _
             "　・ディレクトリだけのリストでいい時は/a:d /s /b" & Chr(13) & _
             "　・ファイルだけのリストでいい時は/a-d /s /b" & Chr(13) & _
             "　・ディレクトリを先に羅列したい場合は/o:g /s /b" & Chr(13) & _
             "・ディレクトリ一覧：     dir /a:d /s /b" & Chr(13) & _
             "・★ファイル一覧(default)：dir /a-d /s /b", "dir命令入れてからOKボタンを押下してください", "dir /a-d /s /b " & path & " | find ""."" ")
        inputcmd = Trim(inputcmd)
        If inputcmd = "" Then Exit Sub
        cmd = inputcmd & " " & " > " & ActiveWorkbook.path & "\" & tmpFilenm & "  2>&1"
        Call ExecuteCMD1(cmd)
        filedata = ReadFile2Arr(ActiveWorkbook.path, tmpFilenm, "SJIS")
        ' Delete tmp File
        Call CreateObject("Scripting.FileSystemObject").DeleteFile(ActiveWorkbook.path & "\" & tmpFilenm)
    End If
    i = Selection.Row
    '#コメント行をプリント
    Call SetAddr(Cells(i, Selection.Column), "※【" & inputcmd & "】", "")
    i = i + 1
    Call SetAddr(Cells(i, Selection.Column), "※上記コマンドを発行した結果（整理後）は↓となります。", "")
    i = i + 1
    '#rootpath行をプリント
    Call SetAddr(Cells(i, Selection.Column), path, path)
    i = i + 1
    '#発行結果を行単位でプリント
    For Each aLine In filedata
        Call SetAddr(Cells(i, Selection.Column + 1), Replace(aLine, path, "."), Trim(aLine))
        i = i + 1
    Next
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    selectHere.Select
    
EXECEPTION:
    If Err.Number <> 0 Then
        MsgBox "生成中エラー： " & Err.Description, vbExclamation, "実行終了"
    End If
End Sub

Private Sub SetAddr(rge As Range, value, link2Path)
    rge.ClearContents
    rge.ClearHyperlinks
    rge.ClearFormats
    rge.value = value
    If IsFileFolderExist(link2Path) Then
        ActiveSheet.Hyperlinks.Add Anchor:=rge, Address:=Trim(link2Path)
    End If
End Sub

Function GetTextFromClipboard() As String
On Error GoTo EXECEPTION
    Set MyData = New DataObject
    MyData.GetFromClipboard
    GetTextFromClipboard = MyData.GetText(1)
EXECEPTION:
    If Err.Number <> 0 Then
        MsgBox Err.Description & vbCrLf, vbExclamation
    End If
End Function

Private Sub ExecuteCMD1(sCmd)
    Dim wExec As Object
On Error GoTo EXECEPTION
    Set wExec = CreateObject("WScript.Shell").Exec("%ComSpec% /c " & sCmd)
    If Trim(sCmd) <> "" Then
        Do While wExec.Status = 0
            DoEvents
        Loop
    Else
        MsgBox "NG : CMD String is Null!!", vbCritical
    End If
EXECEPTION:
    Set wExec = Nothing
End Sub

Public Function GetNow_yyyyMMddHHmmss() As String
    GetNow_yyyyMMddHHmmss = Format(Now, "yyyyMMddHHmmss")
End Function

Function ReadFile2Arr(filePath, fileName, readMojiCode) As String()
    ReDim ret(0) As String 'auto arr
On Error GoTo EXECEPTION
    Dim index As Long
    If Len(Trim(filePath)) = 0 Then
        ' defualt : ThisWorkbook.Path when filePath is null/blank
        filePath = ThisWorkbook.path
    End If
    If Len(Trim(readMojiCode)) = 0 Then
        ' defualt : "UTF-8" when readMojiCode is null/blank
        readMojiCode = "UTF-8"
    End If
    Set objFileSys = CreateObject("Scripting.FileSystemObject")
    Dim StreamReader As Object
    Set StreamReader = CreateObject("ADODB.Stream")
    StreamReader.Charset = readMojiCode
    StreamReader.Type = 2 '?
    StreamReader.Open
    StreamReader.LoadFromFile (objFileSys.BuildPath(filePath, fileName))
    Dim retstring, retStr As String
    Do While Not (StreamReader.EOS)
        retstring = StreamReader.ReadText(-2) 'Read Text 1 row
        retStr = retstring
        '######################################################################
        '### Modify for Local
        'retStr = GetMatchedInnerStrWithRegExp
        'retStr = isMatchedWithRegExp
        'retStr = GetMatchedWithRegExp
        'retStr = GetStringWithRegExpAfterFormat
        '######################################################################
        index = UBound(ret) 'now size
        ReDim Preserve ret(index + 1)  'auto plus 1
        ret(index) = retStr
    Loop
    ReDim Preserve ret(index)  'ReSet size
    
EXECEPTION:
    If Err.Number <> 0 Then
        MsgBox "ReadFile2Arr " & Err.Description, vbExclamation
    End If
    StreamReader.Close
    Set StreamReader = Nothing
    ReadFile2Arr = ret
End Function

Function IsFileFolderExist(filePath) As Boolean
    IsFileFolderExist = False
    If Trim(filePath) <> "" And (Dir(filePath) <> "" Or Dir(filePath, vbDirectory) <> "") Then
        IsFileFolderExist = True
    End If
End Function

Function Trimmer(str) As String
    'RegExpオブジェクトの作成
    Dim reg As Object
    Set reg = CreateObject("VBScript.RegExp")
    
    '正規表現の指定
    With reg
        .Pattern = vbCr & "|" & vbLf & "|" & vbCrLf & "|" & vbTab      'パターンを指定
        .IgnoreCase = False     '大文字と小文字を区別するか(False)、しないか(True)
        .Global = True          '文字列全体を検索するか(True)、しないか(False)
    End With

    Trimmer = reg.Replace(str, "") '指定した正規表現を第2引数の区切り文字に置換
End Function

改善したい箇所あり

・cmdの組み合わせ使用時に、書き方は不正の場合、エラー情報を出力させたいけど、今はできていないこと。
　例：dir <存在しないフォルダー> | find "." >xxx.txt 2>&1
　⇒実行後のxxx.txtに「指定されたパスが見つかりません。」が出力されない。