【SendTo】ネットワークドライブ上のパスをフルパス(UNCパス)に変換する

これは何？

ネットワークドライブ上のパスをフルパス(UNCパス)に変換してクリップボードにコピーするスクリプト。
SendToフォルダに置いて使う。(%APPDATA%\Microsoft\Windows\SendTo)

ネットワークドライブとは

ネットワーク上にある共有フォルダにドライブレターを割り当てて、ローカルPCのストレージと同じようにアクセスできる機能。

例：共有フォルダ「¥¥SERVER¥GROUP1¥SHARE」にドライブレター「H」を割り当てると
　　¥¥SERVER¥GROUP1¥SHARE¥xxx¥yyy¥zzz
に
　　H:¥xxx¥yyy¥zzz
でアクセスできる。

が、他の人にパスを連絡するときは前者(UNCパス)が必要になるので、ネットワークドライブ上のパスをUNCパスに楽に変換したい欲求が出てくる。

コード

ネットワークドライブ上のパスをUNCパスに変換.vbs

Option Explicit

Dim FSO:    Set FSO = CreateObject("Scripting.FileSystemObject")
Dim WSH:    Set WSH = CreateObject("WScript.Shell")

Main

WScript.Quit



'***********************************************************
' メイン関数
'***********************************************************
Sub Main()
    Dim vbReturn
    Dim strArgument
    Dim strFullPath

    ' コマンドラインのファイルを順に処理する
    For Each strArgument In WScript.Arguments.Unnamed
        ' ファイルをUNCパスに変換
        strFullPath = GetUncPath(strArgument)
        If strFullPath = "" Then
            strFullPath = strArgument
        End If

        ' UNCパスをクリップボードにコピー
        Call CopyToClipboard(strFullPath)

        vbReturn = MsgBox(strFullPath, vbOKCancel, "クリップボードにコピーしました。")
        If vbReturn = vbCancel Then
            Exit Sub
        End If
    Next
End Sub



'***********************************************************
' ファイルをUNCパスに変換
'***********************************************************
Function GetUncPath (strFile)
    Dim strDrive
    Dim strNetworkPath
    Dim strFullPath
    Dim wshExec
    Dim strCmdOutput

    ' ドライブレター(「:」を含む)を抽出
    strDrive = Left(strFile, Instr(strFile, ":"))

    ' 「net use」コマンドでドライブの情報を取得
    '
    ' 【実行結果サンプル】
    '   ローカル名         X:
    '   リモート名         \\hostname\xxx\yyy\zzz
    '   リソースの種類     Disk
    '   ステータス         OK
    '   オープン数         *
    '   接続数             *
    '   コマンドは正常に終了しました。
    '
    strFullPath = ""
    Set wshExec = WSH.Exec("cmd /c net use " & strDrive)
    Do Until wshExec.StdOut.AtEndOfline
        strCmdOutput = wshExec.StdOut.ReadLine
        If Instr(strCmdOutput, "リモート名") <> 0 Then
            strNetworkPath = Trim(Right(strCmdOutput, Len(strCmdOutput)-5))
            strFullPath = Replace(strFile, strDrive, strNetworkPath)
        End If
    Loop

    GetUncPath = strFullPath
End Function


'***********************************************************
' テキストをクリップボードにコピー
'***********************************************************
Sub CopyToClipboard(strText)
    Dim wshExec

    ' クリップボードへ出力
    Set wshExec = WSH.Exec("clip")
    wshExec.StdIn.Write(strText)
    wshExec.StdIn.Close()

    ' 参照を解放する
    ' メモ：ＭＳを信じれば(足を)すくわれる
    Set wshExec = Nothing
End Sub

更新履歴

2020/04/03　投稿
2020/04/07　タグ更新