右クリックから出るポップアップメニューでファイルのフルパスを得るサンプル。(Windows7で最初の実行時には管理者権限が必要です)
dim args
dim toClip
dim drive
dim path
On Error Resume Next
If WScript.Arguments.Count = 0 Then
Dim objWshShell
Set objWshShell = WScript.CreateObject("WScript.Shell")
If Err.Number = 0 Then
objWshShell.RegRead("HKCR\Folder\shell\fullpathcopy\")
If Err.Number = 0 Then
objWshShell.RegDelete "HKCR\Folder\shell\fullpathcopy\command\"
objWshShell.RegDelete "HKCR\Folder\shell\fullpathcopy\"
objWshShell.RegDelete "HKCR\*\shell\fullpathcopy\command\"
objWshShell.RegDelete "HKCR\*\shell\fullpathcopy\"
WScript.Echo "右クリックメニューから削除しました。"
Else
Dim scriptPath
scriptPath = "WScript.exe """ & WScript.ScriptFullName & """ ""%1"""
objWshShell.RegWrite "HKCR\Folder\shell\fullpathcopy\", "フルパスをコピー(&F)", "REG_SZ"
objWshShell.RegWrite "HKCR\Folder\shell\fullpathcopy\command\", scriptPath, "REG_SZ"
objWshShell.RegWrite "HKCR\*\shell\fullpathcopy\", "フルパスをコピー(&F)", "REG_SZ"
objWshShell.RegWrite "HKCR\*\shell\fullpathcopy\command\", scriptPath, "REG_SZ"
WScript.Echo "右クリックメニューに登録しました。"
End If
Else
WScript.Echo "エラー: " & Err.Description
End If
Set objWshShell = Nothing
Else
args = WScript.Arguments.Item(0)
drive = Left(args, 2)
path = Right(args, Len(args) - 2)
drive = ChangeNetworkDrive(drive)
toClip = drive & path
ClipSet(toClip)
End If
On Error Goto 0
Sub ClipSet(TextData)
Dim FF
Dim TB
Set FF = CreateObject("Forms.Form.1")
If IsEmpty(FF) Then
Exit Sub
End If
Set TB = FF.Controls.Add("Forms.TextBox.1").Object
TB.MultiLine = True
TB.Text = TextData
TB.SelStart = 0
TB.SelLength = TB.TextLength
TB.Copy
Set TB = Nothing
Set FF = Nothing
End Sub
Function ChangeNetworkDrive(src)
Dim objWshNetwork ' WshNetwork オブジェクト
Dim objDrives ' ドライブ情報
Dim lngLoop ' ループカウンタ
Set objWshNetwork = WScript.CreateObject("WScript.Network")
If Err.Number = 0 Then
Set objDrives = objWshNetwork.EnumNetworkDrives
If Err.Number = 0 Then
If objDrives.Count > 0 Then
For lngLoop = 0 To objDrives.Count - 1 Step 2
If src = objDrives.Item(lngLoop) Then
ChangeNetworkDrive = objDrives.Item(lngLoop + 1)
Set objWshNetwork = Nothing
Exit Function
End If
Next
End If
End If
End If
ChangeNetworkDrive = src
Set objWshNetwork = Nothing
End Function