http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** v11.4 *** www.dieseyer.de *****************************
'
' Datei: kontext-pfadinzwischenablage.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Kontext-Menü des Windows-Explorers werden zwei Einträge
' hinzugefügt:
' "Pfad (Netzpfad) in die Zwischenablage kopieren"
' aus dem Pfad zu einer Datei / zu einem Verzeichnis
' wird versucht den Netzpfad zu ermitteln und in die
' Zwischenablage kopiert:
' C:\Windows\System32\calc.exe
' (auf "MeinPC.Heim.Netz") wird zu
' \\MeinPC\c$\Windows\System32\calc.exe
' Fehlt c$, bleibts bei C:\Windows\System32\calc.exe
' D:\AutoRun.inf
' (CD-Laufwerk auf "PC003.geht.net") wird zu
' \\PC003\d$\AutoRun.inf
' Fehlt d$, bleibts bei D:\AutoRun.inf
' Z:\Sicherung\08-02-13\wichtig.zip
' (auf "Server1.home.net") wird zu
' \\Server1\Sicherung\08-02-13\wichtig.zip
' \\Server1\Sicherung\08-02-13\wichtig.zip
' (auf "Server1.home.net") bleibt bei
' \\Server1\Sicherung\08-02-13\wichtig.zip
'
' "Pfad (Laufwerk) in die Zwischenablage kopieren"
' der Pfad zu einer Datei / zu einem Verzeichnis wird
' unverändert in die Zwischenablage kopiert.
'
' Werden mehrer Dateien / Verzeichnisse übergeben, wird nur
' ein Parameter verwendet (der erste oder der letzte).
'
' Beim direkten Aufruf des VBS wird geprüft, ob es bereits
' 'installiert' ist - wenn ja wird eine 'Deinstallation'
' angeboten.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const KontextName1 = "Pfad (&Netzpfad) in die Zwischenablage kopieren"
Const KontextName2 = "Pfad (Lauf&werk) in die Zwischenablage kopieren"
Const ContextFunc1 = "jaNetz"
Const ContextFunc2 = "neinNetz"
Dim ContextFunc
Const VBSVerz = "dieseyer.de" ' wird zu %ProgramFiles%\dieseyer.de; C:\Programme\dieseyer.de
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim DieseyerVerz : DieseyerVerz = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
Dim i, n, Txt, Tst
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND fso.FileExists( DieseyerVerz ) Then
SkriptDeinst( "063 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND Ucase( DieseyerVerz ) = UCase( WScript.ScriptFullName) Then
SkriptDeinst( "069 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' es müssen min. zwei Parameter vorhanden sein
If oArgs.Count < 2 Then
SkriptInfo( "075 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
ContextFunc = oArgs.item( 0 ) ' Der erste Parameter entscheidet, ob Netzlaufwerk aufgelöst werden soll oder nicht
If not ContextFunc = ContextFunc1 AND not ContextFunc = ContextFunc2 Then
SkriptInfo( "082 :: " ) ' Sub-Prozedur-Aufruf
' SkriptInfo( "083 :: """ & oArgs.item( 0 ) & """ " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' WSHShell.Popup "= = = S T A R T = = =", 2, "088 :: " & WScript.ScriptName
Txt = "" : Tst = ""
For i = 1 to oArgs.Count - 1 ' hole alle Argumente
Tst = oArgs.item( i )
' MsgBox "InStr( " & Tst & ", "":"" ) = " & InStr( Tst, ":" ) & vbCRLF & ContextFunc & "=?=" & ContextFunc1, , "093 :: "
If InStr( Tst, ":" ) = 2 AND ContextFunc = ContextFunc1 Then ' es soll ein Netzwerkpfad ermittelt werden
Tst = NetzPfadVonLwErmitteln( Left( Tst, 1 ) ) ' nur den Lw-Buchstaben
Tst = Tst & Mid( oArgs.item( i ), 3 )
End If
Exit For ' nur ein übergebener Pfad
Next
Call Text2Clipboard( Tst ) ' Txt an die Zwischenablage übergeben
' InPutBox "Folgendes wurde durch das Skript" & vbCRLF & vbCRLF & vbTab & """" & WScript.Scriptname & """" & vbCRLF & vbCRLF & "in der Zwischenablage (Clipboard) eingetragen:", "105 :: " & WScript.Scriptname, Tst
' WSHShell.Popup "= = = E N D E = = =", 1, "107 :: " & WScript.ScriptName
WScript.Quit
'*** v11.4 *** www.dieseyer.de *****************************
Function NetzPfadVonLwErmitteln( Lw )
'***********************************************************
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oDrives : Set oDrives = WSHNet.EnumNetworkDrives
Dim Tst, n
' ist übergebenes Lw ein Pfad?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Lw ) > 2 Then MsgBox Lw & vbCRLF & vbCRLF & Lw, , "123 :: "
If Len( Lw ) > 2 Then NetzPfadVonLwErmitteln = Lw : Exit Function
' ist zweites Zeichen kein Doppelpunkt?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Lw ) = 2 Then If not ":" = Mid( Lw, 2 ) Then MsgBox Lw & vbCRLF & vbCRLF & Lw, , "128 :: "
If Len( Lw ) = 2 Then If not ":" = Mid( Lw, 2 ) Then NetzPfadVonLwErmitteln = Lw : Exit Function
' MsgBox "Function NetzPfadVonLwErmitteln( " & Lw & " )", , "131 :: "
Lw = Left( UCase( Lw ), 1 ) ' nur der Laufwerksbuchstabe
' MsgBox Lw & vbCRLF & vbCRLF & Lw, , "134 :: "
On Error Resume Next
Tst = fso.GetDrive( Lw ).DriveType
' On Error Resume Next
Tst = Int( Tst )
' lokale Festplatte: 2 = fso.GetDrive( Lw ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If 2 = Tst Then
Tst = "\\" & WSHNet.ComputerName & "\" & Lw & "$"
' MsgBox Tst, , "145 :: "
If fso.FolderExists( Tst ) Then NetzPfadVonLwErmitteln = Tst : Exit Function
End If
' verbundenes Netzlaufwerk: 3 = fso.GetDrive( Lw ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Int( 3 ) = Int( Tst ) Then
For n = 0 to oDrives.Count - 1 Step 2
If InStr( oDrives.Item( n ), Lw ) = 1 Then
NetzPfadVonLwErmitteln = oDrives.Item( n + 1 )
' MsgBox oDrives.Item( n ) & vbCRLF & vbCRLF & oDrives.Item( n + 1 ) & vbCRLF & Lw, , "155 :: " & Tst
Exit Function
End If
Next
End If
End Function ' NetzPfadVonLwErmitteln( Lw )
'*** v10.5 *** www.dieseyer.de *****************************
Sub Text2Clipboard( Txt )
'***********************************************************
' http://www.systemscript.com/forumger1/forum_posts.asp?TID=537
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Tst
' ALT: "mshta.exe vbscript:(document.parentwindow.clipboardData.SetData(""text"","" & Txt & ""))(Window.close)"
' NEU: "mshta.exe vbscript:Execute(""document.parentwindow.clipboardData.SetData """"Text"""",""""" & Txt & """"" : self.close"")"
' NEU: "mshta.exe vbscript:Execute(""window.clipboardData.SetData """"Text"""",""""" & Txt & """"" : window.close "")"
' NEU: "mshta.exe vbscript:Execute(""clipboardData.SetData """"Text"""",""""" & Txt & """"" : close"")"
Tst = "mshta.exe vbscript:Execute(""clipboardData.SetData """"Text"""",""""" & Txt & """"" : close"")"
WshShell.Run Tst, , False
' mshta.exe vbscript:Execute("clipboardData.SetData ""Text"",""Text Für die Zwischenablage"" : close")
' mshta.exe vbscript:Execute("document.parentwindow.clipboardData.SetData ""Text"" , ""Text Für die Zwischenablage"" : self.close")
' mshta.exe vbscript:Execute("window.clipboardData.SetData ""Text"",""Text Für die Zwischenablage"" : window.close ")
End Sub ' Text2Clipboard( Txt )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptDeinst( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript (neu) installieren." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Skript entfernen und deinstallieren." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Alles lassen, wie es ist . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "199 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call SkriptInst( "ENTFERNEN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "213 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptDeinst( Ttt )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInfo( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über eine Kontext-Menü-Erweiterung im" & vbCRLF
Txt = Txt & "Windows-Explorer angesprochen werden, um eine Datei" & vbCRLF
Txt = Txt & "oder ein Verzeichnis an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript im Kontext-Menü einfügen." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbNo = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "242 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "251 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInst( SkriptType )
'***********************************************************
' Call SkriptInst( "INSTALLIERN" )
' Call SkriptInst( "ENTFERNEN" )
Const HKCRShellA = "HKCR\*\shell" ' Erweiterung für Dateien
Const HKCRShellB = "HKCR\Folder\shell" ' Erweiterung für Verzeichnisse
Dim Txt, Tst
SkriptType = UCase( SkriptType )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz
If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
If SkriptType = "INSTALLIERN" Then
fso.CopyFile WScript.ScriptFullName, Tst, True
Else
fso.CopyFile WScript.ScriptFullName, Tst & " deaktiviert.txt", True
fso.DeleteFile Tst, True
End If
If SkriptType = "INSTALLIERN" Then
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage1\", KontextName1
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage2\", KontextName2
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage2\Command\", "wscript.exe """ & Tst & """ " & ContextFunc2 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage1\", KontextName1
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage2\", KontextName2
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage2\Command\", "wscript.exe """ & Tst & """ " & ContextFunc2 & " " & chr(34) & "%1" & chr(34)
Else
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage1\Command\"
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage1\"
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage2\Command\"
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage2\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage1\Command\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage1\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage2\Command\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage2\"
End If
Txt = ""
If SkriptType = "INSTALLIERN" Then
Txt = Txt & "Das Skript """ & WScript.ScriptName & """ ist jetzt in das Kontext-Menü des" & vbCRLF
Txt = Txt & "Windows-Explorer eingetragen und über" & vbCRLF & vbCRLF
Txt = Txt & vbTab & """" & Replace( KontextName1, "&", "" ) & """" & vbCRLF
Txt = Txt & "und" & vbCRLF
Txt = Txt & vbTab & """" & Replace( KontextName2, "&", "" ) & """" & vbCRLF
Txt = Txt & "erreichbar."
Else
Txt = Txt & vbTab & "Das Skript " & vbCRLF & vbCRLF
Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Txt & vbTab & "wurde gelöscht und aus dem Kontext-" & vbCRLF & vbCRLF
Txt = Txt & vbTab & "Menü des Windows-Explorer entfernt."
End If
' MsgBox Txt, , "316 :: " & WScript.ScriptName
WSHShell.Popup Txt, 9, "317 :: " & WScript.ScriptName
End Sub ' SkriptInst( SkriptType )
'*** v8.3 *** www.dieseyer.de ******************************
Sub TempHilfeHta
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "337 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "340 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "341 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "342 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, true)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta
http://dieseyer.de • all rights reserved • © 2011 v11.4