元ウィンドウはそのままでショートカット先のフォルダを開くVBS

今回は私がいつも愛用しているVBSを紹介します。

■現状の不満
・Windowsエクスプローラでショートカットファイルを右クリックして「フォルダーの場所を開く」「ファイルの場所を開く」だと元のウィンドウは失われて新しい場所に遷移する。
※もちろん上記動作で良い場合は上記の操作してます。
ショートカットを右クリック時に「新しいウィンドウで開く」が使えればこんなvbsは不要なんですけどね。マイクロソフトさん何とかしてください。

■ショートカットファイルをこのVBSに渡すと以下の動作をします。
①ショートカットがフォルダの場合、元のウィンドウはそのままでそのフォルダを開く
②ショートカットがファイルの場合、元のウィンドウはそのままでそのファイルがあるフォルダを開く

■使い方
以下のスクリプトをテキストエディタに張り付けて、「ショートカットのリンク先フオルダを開く(vbs).vbs」という名前で保存。

上記vbsファイルへのショートカットを以下のフォルダにコピー

C:\Users[user_id]\AppData\Roaming\Microsoft\Windows\SendTo

これでショートカットを右クリック → 送る → ショートカットのリンク先フオルダを開く(vbs).vbs で使えます。

Dim strExName , strPath
Dim arg
Dim oFso
Set oFso = CreateObject("Scripting.FileSystemObject")

' パラメータがあれば処理実行
If WScript.Arguments.Count > O Then
    For Each arg In WScript.Arguments
        ' 拡張子取得
        strExName = oFso.GetExtensionName(arg)
        ' リンクの場合
        If UCase(strExName) ="LNK" Then
        
            ' パスを取得
            strPath = CreateObject("WScript.Shell").CreateShortCut(arg).TargetPath
            
            ' フォルダーが存在する場合
            If oFso.FolderExists(strPath) = True Then
                'そのパスをそのまま使う。
            Else
                ' フオルダーが存在しない場合

                ' ファイルが存在する場合
                If oFso.FileExists(strPath) = True Then
                    ' 一つ上のフォルダのパスを取得
                    strPath = Left(strPath , InStrRev(strPath , "\") -1)
                End If
            End If

            '開く
            CreateObject("Shell.Application").Open strPath
        End If
    Next
End If