http://dieseyer.de • all rights reserved • © 2011 v11.4

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


http://dieseyer.de • all rights reserved • © 2011 v11.4