'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei:  kontext-anzahlzeichenimpfad.vbs
' Autor:  dieseyer@gmx.de
' Auf:    www.dieseyer.de
'
' Erstellt für www.roton.de
'
' Im Kontext-Menü des Windows-Explorers wird ein Eintrag
' hinzugefügt:
' "Anzahl der Zeichen im Pfad ermitteln"
'	durch den die Anzahl der Zeichen des Pfades zu einer 
'	Datei bzw. zu einem Verzeichnis ermittelt und 
'	angezeigt wird.
'
' 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 AnzTeilen   = 88     ' wenn die Länge des Pfades "AnzTeilen" übersteigt, wird die Anzeige des Pfades 'geteilt'

Const KontextName	= "Anzahl der Zei&chen im Pfad ermitteln"

Dim   ContextFunc

Const HKCRShellA	= "HKCR\*\shell"     ' Erweiterung für Dateien
Const HKCRShellB	= "HKCR\Folder\shell"   ' Erweiterung für Verzeichnisse

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 < 1   AND   fso.FileExists( DieseyerVerz ) Then
	SkriptDeinst( "049 :: " ) ' Sub-Prozedur-Aufruf
	WScript.Quit
End If

' Ist das Skript bereits installiert?
If oArgs.Count < 1   AND   Ucase( DieseyerVerz ) = UCase( WScript.ScriptFullName) Then
	SkriptDeinst( "055 :: " ) ' Sub-Prozedur-Aufruf
	WScript.Quit
End If

' es muss ein Parameter vorhanden sein
If oArgs.Count < 1 Then
	SkriptInfo( "061 :: " ) ' Sub-Prozedur-Aufruf
	WScript.Quit
End If

' WSHShell.Popup "= = = S T A R T = = =", 2, "065 :: " & WScript.ScriptName

  Txt = ""
  Txt = oArgs.item( 0 ) ' Der erste Parameter

  If Len( Txt ) < AnzTeilen Then
	Tst = Txt
  Else
	Tst = InStr( Mid( Txt, 4 ), "\" ) + 6 ' das erste \ nach "X:\" oder "\\s"
	Tst = Mid( Txt, 1, Tst ) ' die ersten Zeichen bis zum \
	Tst = Tst & " . . . " & vbCRLF & " . . . "
	Tst = Tst & Mid( Txt, InStrRev( Txt, "\" ) - 3 ) ' die Zeichen ab dem letzten  \
  End If
  Tst = "Das sind     " & Len( Txt ) & "     Zeichen:" & vbCRLF & vbCRLF & Tst

  WSHShell.Popup Tst, 10, "080 :: " & WScript.ScriptName

' WSHShell.Popup "= = = E N D E = = =", 1, "082 :: " & WScript.ScriptName

WScript.Quit



'*** 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, "102 :: " & 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, "116 :: " & 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, "145 :: " & 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, "154 :: " & 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" )
  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 & "\AnzZeichenImPfad\", KontextName
	WSHShell.RegWrite HKCRShellA & "\AnzZeichenImPfad\Command\", "wscript.exe """ & Tst & """ " & ContextFunc & " " & chr(34) & "%1" & chr(34)

	WSHShell.RegWrite HKCRShellB & "\AnzZeichenImPfad\", KontextName
	WSHShell.RegWrite HKCRShellB & "\AnzZeichenImPfad\Command\", "wscript.exe """ & Tst & """ " & ContextFunc & " " & chr(34) & "%1" & chr(34)
  Else
	WSHShell.RegDelete HKCRShellA & "\AnzZeichenImPfad\Command\"
	WSHShell.RegDelete HKCRShellA & "\AnzZeichenImPfad\"

	WSHShell.RegDelete HKCRShellB & "\AnzZeichenImPfad\Command\"
	WSHShell.RegDelete HKCRShellB & "\AnzZeichenImPfad\"
  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( KontextName, "&", "" ) & """" & vbCRLF & 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, , "206 :: " & WScript.ScriptName
  WSHShell.Popup Txt, 9, "207 :: " & 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, , "227 :: " & WScript.ScriptName

	Txt = ""
'	Txt = Txt & vbTab & "230 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
'	Txt = Txt & vbTab & "231 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
'	Txt = Txt & vbTab & "232 :: " & "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