'*** 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 = "" Tst = Tst & vbCRLF & "Info zu """ & WScript.Scriptname & """" Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ " ' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet Tst = Replace( Tst, "< HT", "" Tst = Tst & vbCRLF & "" Tst = Tst & vbCRLF & "
" ' 
 sorgt dafür, dass KEINE Proportionalschrift verwendet wird

  Txt = Tst & vbCRLF & Txt & vbCRLF & "
" 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