'*** 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