http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** v10.B *** www.dieseyer.de *****************************
'
' Datei: kontext-besitzerwerden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Kontext-Menü des Windows-Explorers wird ein Eintrag
' hinzugefügt: "Besitz übernehmen"
'
' 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 = "Besitz &übernehmen"
Const ContextFunc1 = "jaNetz"
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 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 i & ": " & Tst, , "093 :: "
BesitzerWerden Trim( Tst )
' Exit For ' nur ein übergebener Pfad
Next
' 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
'*** v10.B *** www.dieseyer.de *****************************
Function BesitzerWerden( Pfad )
'***********************************************************
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 Tst
Tst = "%comspec% /c CACLS.EXE """ & Pfad & """ /C /T /E /P " & WSHNet.UserName & ":F &&@echo RC '%errorlevel%'&&@pause"
' MsgBox Tst, , "89 :: "
WSHShell.Run Tst, , True
End Function ' BesitzerWerden( Pfad )
'*** 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 = Txt & "[Abbrechen]" & vbTab & "Nichts tun . . . 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, "177 :: " & 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, "191 :: " & 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, "220 :: " & 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, "229 :: " & 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 & "\KontextName1\", KontextName1
WSHShell.RegWrite HKCRShellA & "\KontextName1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\KontextName1\", KontextName1
WSHShell.RegWrite HKCRShellB & "\KontextName1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
Else
WSHShell.RegDelete HKCRShellA & "\KontextName1\Command\"
WSHShell.RegDelete HKCRShellA & "\KontextName1\"
WSHShell.RegDelete HKCRShellB & "\KontextName1\Command\"
WSHShell.RegDelete HKCRShellB & "\KontextName1\"
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 & 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, , "294 :: " & WScript.ScriptName
WSHShell.Popup Txt, 9, "295 :: " & 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, , "315 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "318 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "319 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "320 :: " & "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