Qiita Teams that are logged in
You are not logged in to any team

Log in to Qiita Team
Community
OrganizationAdvent CalendarQiitadon (β)
Service
Qiita JobsQiita ZineQiita Blog
2
Help us understand the problem. What is going on with this article?
@kurapooh

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

More than 1 year has passed since last update.

これは何?

ネットワークドライブ上のパスをフルパス(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()

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

更新履歴

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

2
Help us understand the problem. What is going on with this article?
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
kurapooh

Comments

No comments
Sign up for free and join this conversation.
Sign Up
If you already have a Qiita account Login
2
Help us understand the problem. What is going on with this article?