http://dieseyer.de • all rights reserved • © 2003 v3.B
85 *.VBS-Dateien auf einen Blick:
#########################################################################
>>> anmelden-an-win9x.vbs <<<
'v2.B***************************************************
' File: anmelden-an-win9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt WindowsNT-Version und Sp-Version
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHNetwork = WScript.CreateObject("WScript.Network")
Set Env = WSHShell.Environment("PROCESS")
If Env("OS") = "Windows_NT" then
MsgBox WScript.ScriptName & " läuft nur unter Win95/98/ME!"
WScript.Quit
End if
On Error Resume Next
Txt = WSHNetwork.UserName ' wenn kein Benutzer an Win9x angemeldet ist, gibt's einen Fehler
if not err.number = 0 then
WshShell.Run ("RunDLL32 Shell32,SHExitWindowsEx 0")
Else
WshShell.Run ("C:\TRIO\FLOADER.EXE /5")
End If
WScript.Quit
On Error GoTo 0
#########################################################################
>>> attributechange.vbs <<<
'v3.B***********************************************************
' File: AttributeChange.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Setzt die Attribute aller Dateien in dem übergebenen
' Verzeichnis zurück
'
' Die Anzahl der Zeichen in allen Argumenten darf eine bestimmte
' Menge nicht überschreiten (440 Zeichen?), sonst kommt die
' Fehlermeldung "... - Argumentenliste zu lang."
'***************************************************************
Option Explicit
Dim SendToLink, Text, Txt, TextX, i, lang
Dim WSHShell, fso, oArgs, ShellLink
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
SendToLink = "Attribute ändern"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
lang = 0
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
lang = lang + Len(oArgs.item(i))
if i = 0 then
Text = Left( UCase(oArgs.item(i)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
' if Text = "-S" OR Text = "-I" then SendenAnLink ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
End If
' On Error Resume Next
if fso.FileExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib.exe """ & oArgs.item(i) & """ -s -r -h "
' if fso.FolderExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib """ & oArgs.item(i) & "\*.*"" -s -r -h /s"
' if fso.FolderExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib """ & oArgs.item(i) & "\*.*"" -s -r -h /s"
if fso.FolderExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib.exe """ & oArgs.item(i) & "\*.*"" -s -r -h /s"
' WSHShell.Popup TextX, 10, WScript.ScriptName , 64
WSHShell.run TextX , 4, True
' WSHShell.run TextX , , True
' On Error GoTo 0
Text = Text & i & " " & TextX & vbCRLF
Next
'***************************************************************
' ENDE - das eigentliche Skript endet
'***************************************************************
Text = Replace(Text, "%comspec% /c", "")
Text = Replace(Text, "Attrib.exe", "attrib")
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende. (" & lang & ")" , 64
WScript.Quit
'*********************************
Sub SkriptInfo ' Sub Aufruf
'*********************************
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Entweder ein oder mehrere Dateien bzw. Verzeichnisse " & vbCRLF
Text = Text & "mit der Mouse auf das Skript ziehen und fallen lassen, " & vbCRLF
Text = Text & "oder dem Skript über 'Senden an' die Dateien bzw. " & vbCRLF
Text = Text & "Verzeichnisse übergeben. " & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende." , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & SendToLink & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
#########################################################################
>>> autologonein.vbs <<<
'v2.A***************************************************
' File: AutoLogonEin.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Stellt WinNT/2k/XP auf AutoLogon
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
AutoAdminLogon ="0"
DefaultDomainName ="DS-PC"
DefaultUserName ="musik"
DefaultPassword ="musik"
Key = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
On Error Resume Next
Text = Text & "AutoAdminLogon " & vbTab & WshShell.RegRead( Key & "\AutoAdminLogon" ) & vbCRLF
Text = Text & "DefaultUserName " & vbTab & WshShell.RegRead( Key & "\DefaultUserName" ) & vbCRLF
Text = Text & "DefaultPassword " & vbTab & WshShell.RegRead( Key & "\DefaultPassword" ) & vbCRLF
Text = Text & "DefaultDomainName" & vbTab & WshShell.RegRead( Key & "\DefaultDomainName" ) & vbCRLF
On Error GoTo 0
Text = Text & vbCRLF & "Soll das automatische Login "
If WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then Text = Text & "eingeschaltet werden?"
If not WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then Text = Text & "ausgeschaltet werden?"
Antw = MsgBox (Text, 4 + 32 , WScript.ScriptName)
If Antw = vbNo Then
WshShell.Popup " . . . es bleibt alles beim Alten!" , 10, WScript.ScriptName, 64
' MsgBox " . . . es bleibt alles beim Alten!" , 64, WScript.ScriptName
WScript.Quit
End If
Text = Text & " => Ja!"
If WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then AutoAdminLogon ="1"
If not WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then AutoAdminLogon ="0"
' Werte schreiben
On Error Resume Next
WshShell.RegWrite Key & "\AutoAdminLogon" , AutoAdminLogon
WshShell.RegWrite Key & "\DefaultUserName" , DefaultUserName
WshShell.RegWrite Key & "\DefaultDomainName" , DefaultDomainName
' Schlüssel "\DefaultPassword" anlegen und mit Inhalt füllen; der Schlüssel fehlt manchmal
WshShell.RegWrite Key & "\DefaultPassword" , DefaultPassword , "REG_SZ"
On Error GoTo 0
Text = Text & vbCRLF & vbCRLF
On Error Resume Next
Text = Text & "AutoAdminLogon " & vbTab & WshShell.RegRead( Key & "\AutoAdminLogon" ) & vbCRLF
Text = Text & "DefaultUserName " & vbTab & WshShell.RegRead( Key & "\DefaultUserName" ) & vbCRLF
Text = Text & "DefaultPassword " & vbTab & WshShell.RegRead( Key & "\DefaultPassword" ) & vbCRLF
Text = Text & "DefaultDomainName" & vbTab & WshShell.RegRead( Key & "\DefaultDomainName" ) & vbCRLF
On Error GoTo 0
MsgBox Text
#########################################################################
>>> cd-menu.vbs <<<
'v2.5*****************************************************
' File: cd-menu.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'*********************************************************
Option Explicit
Dim Modus, DriveList, i, RegKey, objAdr, ZielSys, OpSys, Info
Dim ShellLink, LNK, aktCD, CDLw, WSHver, VBver, InfoDatei, LwFrei, LwHDD, LwSum
Dim Titel, Anzeige, Eingabe, aktAusw, Quelle, Ziel, DateiName, DateiNamen, InstDir
Dim Text, TextX, Text1, Text2, Text3, NT_9x, StopStelle, SysLw, FTP, TmpDir
Dim objNet, WSHShell, fso, Param, WSHEnv
InfoDatei = "\auswahl.txt"
Set objNet = WScript.CreateObject("WScript.Network")
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set WSHEnv = WSHShell.Environment("Process")
Set Param = Wscript.Arguments
If Param.Count >= 1 Then Modus = UCase(Param(0))
' ----------------------------------------------
' . . . ein paar Variablen holen
' ----------------------------------------------
' Installationsverzeichnis festlegen: InstDir
' Festplatte mit dem meisten freien Platz ermitteln: LwHDD
' Testen lokalen Eigenschaften: SysLw, TmpDir, VBver, aktCD
' Testen der Windows-Version: ZielSys, OpSys, NT_9x
' nächste Zeile freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CDTest
If Modus = "TEST" Then
Titel = "WSH" & WSHver & " unter " & NT_9x & "/" & OpSys & " (" & aktCD & ")"
Else
Titel = "Auswahlmenü (c) service.cd@gmx.de"
End if
Info = NT_9x & " - OS-Version: " & vbTab & OpSys & vbCRLF
Info = Info & "System Laufwerk: " & vbTab & SysLw & vbCRLF
Info = Info & "CD-Laufwerk: " & vbTab & CDLw & vbCRLF
Info = Info & "Eingelegte CD: " & vbTab & aktCD & vbCRLF
Info = Info & "TMP-Verzeichnis: " & vbTab & TmpDir & vbCRLF
Info = Info & "WSH Version: " & vbTab & WSHver & " / " & VBver & vbCRLF
Info = Info & "Install-Verz.: " & vbTab & InstDir & vbTab & vbTab & LwFrei & " MB frei" & vbCRLF
If Modus = "TEST" Then MsgBox Info, vbOKOnly, Titel
' nächste Zeile nicht freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WScript.Quit
' ----------------------------------------------
' WSH-Version testen und ggf. aktualisieren
' ----------------------------------------------
' scriptde.exe für Windows 2000 / XP
' scr56de.exe für Windows 98 / ME / NT4
If WSHver < "2" Then
TextX = ""
Text = CDLw & "\TOOL\WScript.56\scriptde.exe"
If (fso.FileExists(Text)) AND OpSys = "Windows 2000" Then TextX = Text
Text = CDLw & "\TOOL\WScript.56\scr56de.exe"
If (fso.FileExists(Text)) AND not OpSys = "Windows 2000" Then TextX = Text
If not TextX = "" Then
Text = "Auf diesem PC ist z.Z. WindowsScriptHost Version 1.0 (WSH1) installiert" & vbCRLF
Text = Text & "Dieses Programm läuft besser, einfacher, schneller, höher, weiter, breiter . . ." & vbCRLF
Text = Text & "wenn eine neuere Version installiert ist. " & vbCRLF & vbCRLF
Text = Text & "(" & TextX & ")" & vbCRLF & vbCRLF
Text = Text & "Jetzt installieren? (Ist ein Neustart erforderlich?)"
'nächsten VIER Zeilen freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
aktAusw = MsgBox(Text, vbYesNo + vbDefaultButton1 + vbQuestion, Titel)
if aktAusw <> vbNo Then
WSHShell.Run (TextX),,True
End If
End If
End If
' ----------------------------------------------
' Das Hauptmenü:
' ----------------------------------------------
Do
If Modus = "TEST" Then
Titel = "WSH" & WSHver & " unter " & NT_9x & "/" & OpSys & " (" & aktCD & ")"
Else
Titel = "Auswahlmenü (c) service.cd@gmx.de"
End if
Anzeige = " 2 " & vbTAB & "Windows 2000 SP2 installieren." & vbCRLF
Anzeige = Anzeige & " 4 " & vbTAB & "Windows NT4 SP6a installieren." & vbCRLF
Anzeige = Anzeige & " a " & vbTAB & "Acrobat Reader v5 installieren." & vbCRLF
Anzeige = Anzeige & " f " & vbTAB & "F-PROT Virus-Scanner starten." & vbCRLF
Anzeige = Anzeige & " i6" & vbTAB & "InternetExplorer v6 installiern." & vbCRLF
Anzeige = Anzeige & " j " & vbTAB & "JVM für MS IE v6 installiern." & vbCRLF
Anzeige = Anzeige & " m " & vbTAB & "McAfee VirusScan starten." & vbCRLF
Anzeige = Anzeige & " mc" & vbTAB & "McAfee VirusScan Kopieren & starten." & vbCRLF
Anzeige = Anzeige & " o1" & vbTAB & "Office 2000 SR1 installieren." & vbCRLF
Anzeige = Anzeige & " o2" & vbTAB & "Office 2000 SR1 SP2 installieren." & vbCRLF
Anzeige = Anzeige & " v " & vbTAB & "VC, WinRAR ... kopieren." & vbCRLF
Anzeige = Anzeige & " w " & vbTAB & "Windows Commander starten." & vbCRLF
Anzeige = Anzeige & " wc" & vbTAB & "Windows Commander kopieren & starten." & vbCRLF
If (fso.FileExists(CDLw & InfoDatei)) Then Anzeige = Anzeige & " . . . was soll's denn sein? (h => Hilfe/Info's)"
If not (fso.FileExists(CDLw & InfoDatei)) Then Anzeige = Anzeige & " . . . was soll's denn sein?"
Eingabe = InputBox(Anzeige,Titel,,500,1)
If Eingabe = "" Then ' Abbruch vom Benutzer
' aktAusw = MsgBox(". . . wirklich beenden?", vbYesNo + vbDefaultButton1 + vbQuestion, Titel)
aktAusw = MsgBox(". . . wirklich beenden?", vbYesNo + vbDefaultButton2 + vbQuestion, Titel)
if aktAusw <> vbNo Then WScript.Quit
End If
If UCase(Eingabe) = "TEST" AND Modus = "" Then Modus = "TEST"
If UCase(Eingabe) = "NOTEST" AND Modus = "TEST" Then Modus = ""
If UCase(Eingabe) = "-TEST" AND Modus = "TEST" Then Modus = ""
If Eingabe = "?" Then MsgBox Info, vbOKOnly, Titel
If Eingabe = "ß" Then MsgBox Info, vbOKOnly, Titel
If Eingabe = "2" Then
TextX = CDLw & "\W2kSp2\W2KSP2.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If Eingabe = "4" Then
TextX = CDLw & "\NT4_SP6A\SP6I386.EXE"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "A" Then
TextX = CDLw & "\TOOL\AcroRead\ar500deu.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "F" Then FProtCopy
If UCase(Eingabe) = "H" Then
TextX = CDLw & InfoDatei
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX)
End If
If UCase(Eingabe) = "I6" Then
TextX = CDLw & "\TOOL\ie6\ie6setup.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "J" Then
TextX = CDLw & "\TOOL\WinXX\JVM\msjavx86.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "M" Then
If NT_9x = "NT" Then TextX = CDLw & "\MCAFEE_4.DOS\ScanNT.BAT"
If NT_9x = "9x" Then TextX = CDLw & "\MCAFEE_4.DOS\Scan9x.BAT"
ExeRun
End If
If UCase(Eingabe) = "MC" Then McAfeeCopy
If UCase(Eingabe) = "MI" Then McAfeeCopy
If UCase(Eingabe) = "O1" Then
TextX = CDLw & "\TOOL\O2kSR1\o2ksr1adl.exe"
If (fso.FileExists(TextX)) Then
Ziel = TmpDir & "\o2ksr1"
If (fso.FolderExists(Ziel)) Then fso.DeleteFolder(Ziel), True
WSHShell.Run (TextX & " /T:" & Ziel),,TRUE
TextX = Ziel & "\setup.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
End If
If UCase(Eingabe) = "O2" Then
TextX = CDLw & "\TOOL\Office.2k\O2kSR1Sp2\sp2upd.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "V" Then VCcopy
If UCase(Eingabe) = "W" Then
TextX = CDLw & "\WinCMD\WINCMD32.EXE"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX)
End If
If UCase(Eingabe) = "WC" Then WinCMDcopy
If UCase(Eingabe) = "WI" Then WinCMDcopy
If UCase(Eingabe) = "X" Then WScript.Quit
Loop
Sub VCcopy
' ----------------------------------------------
' DateienListe holen und löschen
' ----------------------------------------------
' Zuerst wird die Liste der zu kopierenden Dateien (Quelle) geholt,
' um dann im Zielverzeichnis genau diese Dateien zu löschen.
' Dadurch gibt es keine Probleme beim überschreiben beim Kopiervorgang.
Quelle = CDLw & "\DISKS\win_pc\win_pc"
If not (fso.FolderExists(Quelle)) Then
MsgBox "Fehler!" & vbCRLF & vbCRLF & "SubVCcopy: Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Set Quelle = fso.GetFolder(WSHShell.ExpandEnvironmentStrings(Quelle))
Set DateiNamen = Quelle.Files
For Each i In DateiNamen
DateiName = ZielSys & "\" & i.Name
On Error Resume Next
fso.DeleteFile(DateiName), True
On Error GoTo 0
Next
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
fso.CopyFolder Quelle, ZielSys
Anzeige = "VC, WinRAR, WinCMD . . . in's lokale System (" & ZielSys & ") kopieren . . ." & vbCRLF & vbCRLF
Anzeige = Anzeige & ". . . ist erledigt! "
MsgBox Anzeige,, Titel
End Sub ' VCcopy
Sub McAfeeCopy
Quelle = CDLw & "\MCAFEE_4.DOS"
If not (fso.FolderExists(Quelle)) Then ' Quelle vorhanden?
MsgBox "SubMcAfeeCopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Ziel = InstDir & "\MCAFEE_4.DOS"
Ziel = WSHShell.ExpandEnvironmentStrings(Ziel)
If (fso.FolderExists(Ziel)) Then ' Zielverzeichnis löschen, fals vorhanden
If Modus = "TEST" Then MsgBox Ziel & " wird gelöscht",, Titel
fso.DeleteFolder(Ziel), True
End If
fso.CopyFolder Quelle, Ziel ' Quelle ins Zielverzeichnis kopieren
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
' fso.DeleteFile(Ziel & "\clean.dat"), True ' clean.dat löschen - damit kann man Geld verdienen
If NT_9x = "NT" Then TextX = Ziel & "\ScanNT.BAT"
If NT_9x = "9x" Then TextX = Ziel & "\Scan9x.BAT"
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\ma.lnk")
Text1 = "LNK: " & vbTab & WSHShell.CreateShortcut(ZielSys & "\ma.lnk") & vbCRLF
ShellLink.TargetPath = TextX
Text1 = Text1 & "Target: " & vbTab & TextX & vbCRLF
ShellLink.WorkingDirectory = Ziel
Text1 = Text1 & "WorkDir: " & vbTab & Ziel & vbCRLF
ShellLink.Save
If Modus = "TEST" Then MsgBox "Folgende Verknüpfung wurde erstellt: " & vbCRLF & Text1,,Titel
Anzeige = Quelle & " wurde nach " & Ziel & " kopiert!" & vbCRLF & vbCRLF
Anzeige = Anzeige & "McAfee - Scan kann per <Start> <Ausführen> "" ma "" aufgerufen werden."
MsgBox Anzeige,, Titel
WSHShell.Run ("ma")
End Sub ' McAfeeCopy
Sub SuperScanCopy
Quelle = CDLw & "\Tool\SuperScan"
If not (fso.FolderExists(Quelle)) Then ' Quelle vorhanden?
MsgBox "SuperScanCopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Set Quelle = fso.GetFolder(WSHShell.ExpandEnvironmentStrings(Quelle))
Set DateiNamen = Quelle.Files
For Each i In DateiNamen ' Quell-Dateien-Liste
DateiName = ZielSys & "\" & i.Name ' ist Liste der zu löschenden
On Error Resume Next ' Dateien im Zielverzeichnis
' MsgBox Dateiname,,Titel
fso.DeleteFile(DateiName), True
On Error GoTo 0
Next
Ziel = InstDir & "\SuperSc"
Ziel = WSHShell.ExpandEnvironmentStrings(Ziel)
' Zielverzeichnis löschen, fals vorhanden
If (fso.FolderExists(Ziel)) Then fso.DeleteFolder(Ziel), True
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
fso.CopyFolder Quelle, Ziel
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\scanner.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\SS.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\SScan.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\SuperScan.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Anzeige = Quelle & " wurde nach " & Ziel & " kopiert!" & vbCRLF & vbCRLF
Anzeige = Anzeige & "SuperScan kann per <Start> <Ausführen> "" SScan "" aufgerufen werden."
MsgBox Anzeige,, Titel
WSHShell.Run ("ss")
End Sub ' SuperScanCopy
Sub WinCMDcopy
' ----------------------------------------------
' DateienListe holen und löschen
' ----------------------------------------------
' Zuerst wird die Liste der zu kopierenden Dateien (Quelle) geholt,
' um dann im Zielverzeichnis genau diese Dateien zu löschen.
' Dadurch gibt es keine Probleme beim überschreiben beim Kopiervorgang.
Quelle = CDLw & "\WinCMD"
Ziel = InstDir & "\WinCMD"
If not (fso.FolderExists(Quelle)) Then
MsgBox "SubWinCMDcopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
If Modus = "TEST" Then MsgBox Ziel & " wird gelöscht . . . ",, Titel
If (fso.FolderExists(Ziel)) Then fso.DeleteFolder(Ziel), True
If Modus = "TEST" Then MsgBox Ziel & " ist gelöscht . . . ",, Titel
If Modus = "TEST" Then MsgBox Quelle & " wird jetzt nach " & Ziel & " kopiert!",, Titel
fso.CopyFolder Quelle, Ziel
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\wc.lnk")
ShellLink.TargetPath = Ziel & "\Wincmd32.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\wincmd.lnk")
ShellLink.TargetPath = Ziel & "\Wincmd32.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\wincmd32.lnk")
ShellLink.TargetPath = Ziel & "\Wincmd32.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Anzeige = Quelle & " wurde nach " & Ziel & " kopiert!" & vbCRLF & vbCRLF
Anzeige = Anzeige & "WinCommander kann per <Start> <Ausführen> "" wc "" aufgerufen werden."
MsgBox Anzeige,, Titel
WSHShell.Run ("wc")
End Sub ' WinCMDcopy
Sub FProtCopy
' ----------------------------------------------
' DateienListe holen und löschen
' ----------------------------------------------
' Zuerst wird die Liste der zu kopierenden Dateien (Quelle) geholt,
' um dann im Zielverzeichnis genau diese Dateien zu löschen.
' Dadurch gibt es keine Probleme beim überschreiben beim Kopiervorgang.
Quelle = CDLw & "\F-Prot"
Ziel = InstDir & "\F-Prot"
If not (fso.FolderExists(Quelle)) Then
MsgBox "SubFProtCopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Set Quelle = fso.GetFolder(WSHShell.ExpandEnvironmentStrings(Quelle))
Set DateiNamen = Quelle.Files
For Each i In DateiNamen
DateiName = Ziel & "\" & i.Name
On Error Resume Next
' MsgBox Dateiname,,Titel
fso.DeleteFile(DateiName), True
On Error GoTo 0
Next
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
fso.CopyFolder Quelle, Ziel
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\fp.lnk")
ShellLink.TargetPath = Ziel & "\fp.bat"
ShellLink.WorkingDirectory = Ziel
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\f-prot.lnk")
ShellLink.TargetPath = Ziel & "\fp.bat"
ShellLink.WorkingDirectory = Ziel
ShellLink.Save
If Modus = "TEST" Then MsgBox "Folgende Verknüpfung wurde erstellt: " & vbCRLF & ZielSys & "\f-p.lnk",,Titel
Anzeige = "F-PROT . . . nach " & Ziel & " kopieren . . ." & vbCRLF
Anzeige = Anzeige & ". . . ist erledigt! " & vbCRLF & vbCRLF
Anzeige = Anzeige & "F-PROT wird jetzt gestartet! "
MsgBox Anzeige,, Titel
WSHShell.Run ("fp")
End Sub ' FProtCopy
Sub ExeRun
' ----------------------------------------------
' *.exe - Datei ausführen
' ----------------------------------------------
' Es wird ein Verknüpfung %TMP%\?????.lnk erstellt, die zusätzlich
' das Arbeitsverzeichnis enthält - manche Programme laufen sonst nicht
If not (fso.FileExists(TextX)) Then
MsgBox "Fehler!" & vbCRLF & vbCRLF & "SubExeRun: Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
Exit Sub
End If
LNK = Mid(TextX, (InstrRev(TextX, "\")+1))
LNK = Left( LNK, (Instr(LNK, ".")-1))
If Modus = "TEST" Then MsgBox "SubExeRUN erstellt folgenden Link und ruft ihn auf: " & vbCRLF & LNK,,Titel
Text = TmpDir & "\" & LNK
If (fso.FileExists(Text & ".pif")) Then
fso.DeleteFile(Text & ".pif"), True
If Modus = "TEST" Then MsgBox Text & ".pif . . . gelöscht!" ,,Titel
End If
If (fso.FileExists(Text & ".lnk")) Then
fso.DeleteFile(Text & ".lnk"), True
If Modus = "TEST" Then MsgBox Text & ".lnk . . . gelöscht!",,Titel
End If
If (fso.FileExists(Text & ".")) Then
fso.DeleteFile(Text & "."), True
If Modus = "TEST" Then MsgBox Text & ". . . . gelöscht!" ,,Titel
End If
If (fso.FileExists(Text)) Then
fso.DeleteFile(Text), True
If Modus = "TEST" Then MsgBox Text & " . . . gelöscht!" ,,Titel
End If
Set ShellLink = WSHShell.CreateShortcut(Text & ".lnk")
Text1 = "LNK: " & vbTab & WSHShell.CreateShortcut(Text & ".lnk") & vbCRLF
ShellLink.WorkingDirectory = Left(TextX, InstrRev(TextX, "\"))
Text1 = Text1 & "WorkDir: " & vbTab & Left(TextX, InstrRev(TextX, "\")) & vbCRLF
ShellLink.TargetPath = TextX
Text1 = Text1 & "Target: " & vbTab & Left(TextX, InstrRev(TextX, "\")) & vbCRLF
ShellLink.Save
If Modus = "TEST" Then MsgBox "Folgende Verknüpfung wurde erstellt: " & vbCRLF & Text1,,Titel
' Text = Text & ".lnk"
If Modus = "TEST" Then MsgBox Text & vbCRLF & "wird aufgerufen . . .",,Titel
WSHShell.Run Text
' WSHShell.Run (Text),,True ' auf Anwendungsende warten geht nicht immer
' WScript.Sleep 7500 ' geht erst ab WSH2
End Sub ' ExeRun
Sub CDTest
' ---------------------------------------------------------
' Testen der Windows-Version: ZielSys, OpSys, NT_9x
' ---------------------------------------------------------
On Error Resume Next
RegKey = "HKLM\Software\Microsoft\Windows\CurrentVersion\Productname"
TextX = WSHShell.RegRead(RegKey)
If not err.number <> 0 Then
ZielSys = "Command"
OpSys = WSHShell.RegRead(RegKey)
NT_9x = "9x"
End if
On Error GoTo 0
On Error Resume Next
RegKey = "HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion"
TextX = "Windows NT " & WSHShell.RegRead(RegKey)
If not err.number <> 0 Then
ZielSys = "System32"
OpSys = "Windows NT " & WSHShell.RegRead(RegKey)
NT_9x = "NT"
End if
On Error GoTo 0
On Error Resume Next
RegKey = "HKLM\Software\Microsoft\Windows NT\CurrentVersion\Productname"
TextX = WSHShell.RegRead(RegKey)
If not err.number <> 0 Then
ZielSys = "System32"
OpSys = WSHShell.RegRead(RegKey)
NT_9x = "NT"
End if
On Error GoTo 0
Zielsys = WSHShell.ExpandEnvironmentStrings(WSHShell.Environment.Item("WINDIR")) & "\" & ZielSys
' ---------------------------------------------------------
' Lokalen Eigenschaften: SysLw, TmpDir, VBver, aktCD
' ---------------------------------------------------------
CDLw = Left (fso.GetFolder("."), 2) ' CD-Lw.-Buchstabe
aktCD = fso.GetDrive(fso.GetDriveName(CDLw)).VolumeName ' CD-Label
SysLw = Left (WSHEnv ("WINDIR"), 3)
TmpDir = WSHEnv("TEMP")
If TmpDir = "" Then TmpDir = WSHEnv("TMP")
' Unter Win2k ist das Temp-Verz. ?:\Dokumente und Einstellungen\UserName\TEMP
' Wenn TmpDir das ..\UserName\TEMP-Verzeichnis ist und ein ?:\Winnt\TEMP existiert,
' wird TmpDir auf ?:\Winnt\TEMP geändert
if 0 <> InstrRev(TmpDir, objNet.UserName) AND (fso.FolderExists(WSHEnv("SystemRoot") & "\TEMP")) Then TmpDir = WSHEnv("SystemRoot") & "\TEMP"
VBver = WScript.Version
if VBver < "5.1" Then WSHver = "1"
if VBver = "5.1" Then WSHver = "2"
if VBver = "5.6" Then WSHver = "5.6"
if VBver > "5.6" Then WSHver = ">5.6"
' ---------------------------------------------------------
' Festplatte mit dem meisten freien Platz ermitteln: LwHDD
' ---------------------------------------------------------
Set DriveList = fso.Drives
LwFrei = CInt(0)
For Each i in DriveList
if 2 = i.DriveType Then
If i.IsReady Then
If LwFrei < CInt(FormatNumber(i.FreeSpace/1024/1024, 0)) Then
LwFrei = CInt(FormatNumber(i.FreeSpace/1024/1024, 0))
LwHDD = i.DriveLetter & ":"
LwSum = CInt(FormatNumber(i.TotalSize/1024/1024, 0))
End If
End If
End If
Next
' ---------------------------------------------------------
' Installationsverzeichnis festlegen: InstDir
' ---------------------------------------------------------
' Hier werden Dateien abelegt, die für spätere oder wiederholte Installationen
' bzw. Updates erforderlich sind. Nachdem das %TEMP% Verzeichnis als InstDir festgelegt
' wurde, wird zunächst versucht auf dem SystemLaufwerk (meist C:) und anschließend auf
' LwHDD (Festplatte/Partition auf dem System mit dem meisten freien Platz; z.B. D:) ein
' vorhandenes Verzeichnis (setups, setup oder install) zu finden. Existiert ein solches
' Verzeichnis, wird InstDir überschrieben.
If (fso.FolderExists(TmpDir)) Then InstDir = WSHShell.ExpandEnvironmentStrings(TmpDir)
If (fso.FolderExists(SysLw & "setups" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\setups")
If (fso.FolderExists(SysLw & "setup" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\setup")
If (fso.FolderExists(SysLw & "install")) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\install")
If (fso.FolderExists(SysLw & "driver" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\install")
If (fso.FolderExists(SysLw & "treiber")) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\install")
If (fso.FolderExists(LwHDD & "\setups" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\setups")
If (fso.FolderExists(LwHDD & "\setup" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\setup")
If (fso.FolderExists(LwHDD & "\install")) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\install")
If (fso.FolderExists(LwHDD & "\driver" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\install")
If (fso.FolderExists(LwHDD & "\treiber")) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\install")
If Modus = "TEST" Then MsgBox LwHDD & " ist das Laufwerk mit dem meisten freien Platz: " & LwFrei & " MB von " & LwSum & " MB frei. ", vbOKOnly, Titel
End Sub ' CDTest
#########################################################################
>>> cd-start.vbs <<<
'v3.A**********************************************************
' File: CDstart.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' So startet man automatisch ein Skript durch die
' Autorun-Funktion des (MS-) Betriebssystems
'**************************************************************
'
' Auf der CD müssen sich im Hauptverzeichnis folgende Dateien befinden:
'
' autorun.inf
' ~~~~~~~~~~~
' Inhalt der autorun.inf:
' [autorun]
' open=ShelExec.exe cdstart.vbs
'
' ShelExec.exe (160kBytes)
' ~~~~~~~~~~~~
' von http://www.naughter.com/shelexec.html
'
' cdstart.vbs
' ~~~~~~~~~~~
' Inhalt der cdstart.vbs
' WScript.CreateObject("WScript.Shell").run ("menu.vbs"),0 ,true
' WScript.CreateObject("WScript.Shell").Popup ("Das Menü wird jetzt gestartet . . . "),15
WScript.CreateObject("WScript.Shell").run ("menu.vbs"),0 ,true
' WScript.CreateObject("WScript.Shell").Popup ("Das Menü ist jetzt beendet . . . "),15
#########################################################################
>>> cdauswerfen.vbs <<<
'v3.7*****************************************************
' File: CDauswerfen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
' Nach Info's von Thorsten Gudera, Christoph Basedau
'*********************************************************
Option Explicit
Dim WshShell, fso, ShellApp, DriveList, CDLw, Name, CDex
Dim i, Text
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
' shell32.dll version 4.71 or later
' http://msdn.microsoft.com/library/en-us/shellcc/platform/Shell/reference/objects/folder/copyhere.asp
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME )
Text = "\system32"
If not "Windows_NT" = WScript.CreateObject("WScript.Shell").Environment("Process")("OS") then Text = "\system"
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
Text = fso.GetFileVersion( text ) ' Versionsinfo (der Shell32.dll) holen
' wshshell.Popup "Die Shell32.dll hat die Version " & Text , 3, WScript.ScriptName
Text = Left ( CDbl ( text ), 3 ) ' Versionsinfo formatieren
If Text < 471 then
wshshell.Popup "Es ist ein Shell32.dll mit der Version 4.71 oder höher erforderlich." , 30, WScript.ScriptName & " - Ende"
WScript.Quit
End If
Set DriveList = fso.Drives
For Each i in DriveList
' if 0 = i.DriveType Then Text = "??? " & vbTab & i.DriveLetter & ": " & vbTab
' if 1 = i.DriveType Then Text = "Disk-Lw." & vbTab & i.DriveLetter & ": " & vbTab
' if 2 = i.DriveType Then Text = "Festpl. " & vbTab & i.DriveLetter & ": " & vbTab
' if 4 = i.DriveType Then Text = "CD-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
' if 3 = i.DriveType Then Text = "Netz-Lw." & vbTab & i.DriveLetter & ": " & vbTab
' if 5 = i.DriveType Then Text = "RAM-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
if 4 = i.DriveType Then
CDLw = i.DriveLetter & ":\"
' If i.IsReady Then
Set ShellApp=CreateObject("Shell.Application")
' MsgBox ShellApp.NameSpace(17)
Set Name = ShellApp.NameSpace(17)
' MsgBox Name.ParseName( "F:\" )
' MsgBox Name.ParseName( CDLw )
' Set CDex=Name.ParseName( "F:\" )
Set CDex=Name.ParseName( CDLw )
' CDex.InvokeVerb("Auto&Play") ' WinNT Server engl.
CDex.InvokeVerb("E&ject") ' WinNT Server engl.
CDex.InvokeVerb("Auswerfen")
' MsgBox "1"
CDex.InvokeVerb("&Auswerfen") ' Win2k Prof dt.
' MsgBox "2"
CDex.InvokeVerb("A&uswerfen")
' MsgBox "3"
' End If
End If
Next
MsgBox "Ende ", , WScript.ScriptName
#########################################################################
>>> cddurchsuchen.vbs <<<
'v3.7*****************************************************
' File: CDdurchsuchen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Das Skript sucht nach einem CD-Laufwerk und schreibt
' eine Inhaltsliste, die durchsucht werden kann.
' Oder man zieht eine Datei auf das Skript, die sich dann
' durchsuchen lässt.
'*********************************************************
Option Explicit
Dim WshShell, fso, FileOut, DriveList, i, CDlw
Dim Liste, LstType, Text, objArgs
LstType = ".html"
LstType = ".txt"
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set DriveList = fso.Drives
Set objArgs = WScript.Arguments
For i = 0 to objArgs.Count - 1
Liste = objArgs(i)
Exit For
Next
Set objArgs = nothing
if fso.FileExists( Liste ) then
ListeAnz ( Liste )
End If
For Each i in DriveList
if 4 = i.DriveType AND i.IsReady Then
CDlw = CDlw & vbTab & i.DriveLetter & ":"& vbTab & i.VolumeName & vbCRLF
End If
Next
CDlw = "Die CD-Laufwerke enthalten folgende CD's:" & vbCRLF & vbCRLF & CDlw
CDlw = CDlw & "Von welchem Laufwerk soll eine Inhaltsliste erzeugt werden?"
CDlw = InputBox( CDlw, WScript.ScriptName)
If CDlw = "" then
MsgBox ". . . das ist das Ende!", , Wscript.ScriptName
Wscript.Quit
End If
CDlw = Left( CDlw, 1) & ":"
Set i = fso.GetDrive( CDlw )
if not 4 = i.DriveType OR not i.IsReady Then
MsgBox UCase( CDlw ) & " ist kein CD-Laufwerk!" & vbCRLF & vbCRLF & ". . . das ist das Ende!", , WScript.ScriptName
Wscript.Quit
End If
Liste = i.VolumeName
if not fso.FileExists( Liste & "1" & LstType ) then
Liste = Liste & "1" & LstType
Else
Text = "Zu der CD " & Liste & " in Laufwerk " & UCase( CDlw ) & " existieren folgende Inhaltslisten:" & vbCRLF & vbCRLF
For i = 1 to 9
if fso.FileExists( Liste & i & LstType ) then
Text = Text & Liste & i & LstType & vbCRLF
End If
Next
Text = Text & vbCRLF
Text = Text & "[JA]" & vbTab & " Eine weitere Datei anlegen (notfalls eine Löschen)." & vbCRLF
Text = Text & "[Nein]" & vbTab & " Alle Dateien löschen und eine " & Liste & "1" & LstType & " erstellen." & vbCRLF
Text = MsgBox( Text, 3 + 32, WScript.ScriptName )
if Text = vbCancel then
MsgBox ". . . das ist das Ende!", , Wscript.ScriptName
Wscript.Quit
End If
if Text = vbNo then
For i = 1 to 9
if fso.FileExists( Liste & i & LstType ) then fso.DeleteFile( Liste & i & LstType ), true
Next
Liste = Liste & "1" & LstType
End If
if Text = vbYes then
For i = 9 to 1 Step -1
if not fso.FileExists( Liste & i & LstType ) then Text = i
Next
If Text < 1 then
MsgBox "Es gibt bereits 9 " & Liste & " Dateien - es MUSS gelöscht werden!" & vbCRLF & vbCRLF & ". . . das ist das Ende!", , Wscript.ScriptName
Wscript.Quit
End If
Liste = Liste & Text & LstType
End If
End If
Set FileOut = fso.OpenTextFile( Liste, 8, True)
FileOut.WriteLine Liste & " - Verzeichnis vom " & Now
FileOut.WriteLine " "
FileOut.Close
Set FileOut = nothing
WSHShell.Run "%comspec% /c dir " & CDlw & "\ /s /b >> " & Liste, ,True
ListeAnz ( Liste )
Wscript.Quit
Sub ListeAnz ( Datei )
WSHShell.Run Datei
WScript.Sleep 1000
WshShell.SendKeys ( "^F" )
End Sub
#########################################################################
>>> command-hier.vbs <<<
'v3.5***************************************************
' File: command-hier.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Erstellt Kontexteintrag: mit der rechten Mouse-Taste
' auf ein Verzeichnis öffnet eine Eingabeaufforderung
' (DOS-Prompt) mit/in diesem Verzeichnis.
'*******************************************************
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objShell = CreateObject("WScript.Shell")
Set WshSysEnv = WshShell.Environment("SYSTEM")
Text = WSHShell.ExpandEnvironmentStrings("%comspec%")
objShell.RegWrite "HKCR\Folder\Shell\MenuText\Command\", Text & " /k cd " & chr(34) & "%1" & chr(34)
objShell.RegWrite "HKCR\Folder\Shell\MenuText\", "Command Prompt Hier"
#########################################################################
>>> cr2crlf.vbs <<<
'v3.5********************************************************
' File: cr2crlf.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' wandelt in einer Datei jedes CR zu CRLF um (und löscht alle
' CRLFLF).
'************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird halt das Skript gelesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = i + 1
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
' Zeile(i) = i & vbTab & Zeile(i)
Zeile(i) = Replace( Zeile(i), vbCR, vbCRLF )
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF )
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF & "#X#" & i)
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF & "#X#" & i)
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF & "#X#" & i)
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.DeleteFile( Datei )
#########################################################################
>>> datei-verzeichnis-liste.vbs <<<
'v3.6*****************************************************
' File: Datei-Verzeichnis-Liste.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle Dateien und danach alle Verzeichnisse
' in einem / dem aktuellen Verzeichnis
' Zieht man ein Verzeichnis oder eine Datei auf das Skript
' werden zu diesem Verzeichnis die Info's angezeigt.
'*********************************************************
Option Explicit
Dim WSHShell, fso, oArgs
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, Text, Pfad, DateiX, VerzX, Verz(), Datei()
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
If oArgs.Count > 0 Then ' gibt es Argumente?
Pfad = oArgs.item(0) ' erstes Argument
if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad )
' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist
Else ' es gibt keine Argumente!
Pfad = fso.GetFolder( "." ) ' Verzeichnis, in dem sich das Skript befindet
End If
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
' Dateiliste an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
ReDim Preserve Datei(i)
Datei(i) = DateiX.Name
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' Array an Text übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
If i > 0 then ' wenn es Datei(en) gibt
For i = 0 to UBound( Datei )
Text = Text & Pfad & "\" & Datei(i) & vbCRLF
Next
Else
Text = "keine Dateien vorhanden."
End If
MsgBox UCase(Pfad) & " enthält folgende Dateien:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
' Verzeichnisliste an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oSubFolder = oFolders.SubFolders
For Each VerzX In oSubFolder
ReDim Preserve Verz(i)
Verz(i) = VerzX.Name
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' Array an Text übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
If i > 0 then ' wenn es Verzeichnis(se) gibt
For i = 0 to UBound( Verz )
Text = Text & Pfad & "\" & Verz(i) & vbCRLF
Next
Else
Text = "keine Unterverzeichnisse vorhanden."
End If
MsgBox UCase(Pfad) & " enthält folgende Verzeichnisse:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
#########################################################################
>>> dateialshtml.vbs <<<
'v3.7********************************************************
' File: DateiAlsHtml.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut, FileOutAll, oFolders, oFiles, oSubFolder
Dim Datei(), DateiX, VerzX, i, oArgs
Dim Txt, Text
Dim Quelle, Ziel, LaufW, Schreiben
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Quelle = oArgs.item(i)
Exit For ' ein Argument reicht
Next
if Quelle = "" then Quelle = WScript.ScriptName
' MsgBox Quelle, , WScript.ScriptName & " Anfang"
Quelle = fso.GetFile( Quelle ).Path
VBS1zuHTML (Quelle)
WSHShell.Popup Quelle & vbCRLF & vbCRLF & ". . . wurde in eine .HTML-Datei kopiert." , 10, WScript.ScriptName , 64
WScript.Quit
'************************************************************
Sub VBS1zuHTML (DateiX) ' Aufruf
'************************************************************
' .vbs-Datei bearbeiten und als .html speichern
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile( DateiX , 1, true) ' Datei zum Lesen öffnen
DateiX = fso.GetParentFolderName( DateiX ) & "\" & fso.GetBaseName( DateiX ) & ".html"
Set FileOut = FSO.OpenTextFile( DateiX, 2, true) ' Datei zum Schreiben öffnen; 2: immer neu anlegen
' Titelzeile für Skript in .html
FileOut.WriteLine "<body onLoad=""window.moveTo(screen.width-750),window.resizeTo(750,screen.height-50)"" >"
FileOut.WriteLine "<style type=""text/css""> <!-- body { background-color:#FFFFCC; line-height:45%; margin-left:20px; } --> </style> "
FileOut.WriteLine "<b><a href=""http://dieseyer.de"">http://dieseyer.de • all rights reserved • © " & VerNeuPunkt() & "</a></b>"
FileOut.WriteLine "<pre><br>"
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Txt = FileIn.Readline
FileOut.WriteLine( Txt & " <br>" )
Txt = Replace( Txt, ">", "&62" )
Txt = Replace( Txt, "<", "&60" )
FileOut.WriteLine( Txt & " <br>" )
Loop
' Fußzeile Skript in .html
FileOut.WriteLine "</pre>"
FileOut.WriteLine "<b><a href=""http://dieseyer.de"" target= ""_blank"">http://dieseyer.de • all rights reserved • © " & VerNeuPunkt() & "</a></b>"
FileOut.WriteLine "</body>"
FileIn.Close
FileOut.Close
Set FileIn = nothing
Set FileOut = nothing
WSHShell.run """C:\Programme\Internet Explorer\IEXPLORE.EXE"" " & DateiX
End Sub ' VBS1zuHTML (DateiX)
'************************************************************
Function VerNeuPunkt() ' Aufruf
'************************************************************
' dreistellige Jahreszahl & einstellige Jahreszahl + einstellige Monatszeichen
Dim Diff
Diff = 5
Diff = now() - Diff
VerNeuPunkt = Year( Diff ) & " v"
If Month( Diff ) < 10 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & "." & Month( Diff )
' MsgBox Month( Diff )
If Month( Diff ) = 10 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & ".A"
If Month( Diff ) = 11 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & ".B"
If Month( Diff ) = 12 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & ".C"
End Function ' VerNeuPunkt ()
#########################################################################
>>> dateienaltdelete.vbs <<<
'v3.7*****************************************************
' File: DateienAltDelete.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Löscht alle Dateien, die seit einem bestimmten Datum
' nicht mehr geändert wurden
'*********************************************************
Option Explicit
Dim Pfad, Alter
Pfad = "d:\setup"
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet, Skript wird also auch gelöscht
Pfad = "c:\temp"
Alter = 365 ' Dateien, die seit xxx Tagen nicht geändert wurden
MsgBox AltesLoeschen (Pfad, Alter ) 'Function Aufruf und Ergebnisanzeige
AltesLoeschen "c:\temp", 100 'Function Aufruf OHNE Ergebnisanzeige
' ~~~~~~
WScript.Quit
'*********************************************************
Function AltesLoeschen (Pfad, Alter) ' Anfang
'*********************************************************
Dim fso, oFiles, i, Txt
Alter = FormatDateTime( now() - Alter ,2)
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!", , WScript.ScriptName
Exit Function
End If
AltesLoeschen = "In " & UCase( Pfad ) & " wurden vor dem " & Alter & " geändert Dateien gelöscht." & vbCRLF & vbCRLF
Set oFiles = fso.GetFolder( Pfad ).Files
For Each i In oFiles
if DateDiff("d" , i.DateLastModified, Alter) > 0 then ' vor dem Alter geänderte Dateien
Txt = i.path ' nach dem Löschen von i.Path ist auch i.Path gelöscht
AltesLoeschen = AltesLoeschen & i.Name & " " & vbTab & FormatDateTime( i.DateLastModified ,2)
On Error Resume Next
fso.DeleteFile i.path, True
On Error GoTo 0
If not fso.FileExists( Txt ) Then
AltesLoeschen = AltesLoeschen & vbCRLF
Else
AltesLoeschen = AltesLoeschen & " nicht gelöscht." & vbCRLF
End if
End If
Next
Set oFiles = nothing
Set fso = nothing
End Function ' AltesLoeschen
#########################################################################
>>> dateienvergleich.vbs <<<
'v3.B***********************************************************
' File: DateienVergleich.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Vergleicht 2 Dateien mit "fc /b %1 %2"
'***************************************************************
Option Explicit
Dim SendToLink, Text, Txt, TextX, i, lang
Dim WSHShell, fso, oArgs, ShellLink
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
SendToLink = "2 Dateien vergleichen"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
If oArgs.Count = 1 then
Text = Left( UCase(oArgs.item(0)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
End If
If not oArgs.Count = 2 then
SkriptInfo ' SUB Aufruf
Else
Text = vbCRLF
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if fso.FileExists( oArgs.item(i) ) then
TextX = TextX & """" & oArgs.item(i) & """ "
Text = Text & oArgs.item(i) & vbCRLF
End If
Next
End If
Text = "Die Dateien " & vbCRLF & Text & vbCRLF & "werden jetzt BINÄR verglichen." & vbCRLF & vbCRLF
Text = Text & ". . . oder reicht ein TEXT -Vergleich? [Yes] in 5 sec."
Text = WSHShell.Popup (Text, 10, WScript.ScriptName , 32+3 )
if Text = -1 then TextX = "%comspec% /c fc /N " & TextX
if Text = vbYes then TextX = "%comspec% /c fc /N " & TextX
if Text = vbNo then TextX = "%comspec% /c fc /B " & TextX
if Text = vbCancel then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 48
WScript.Quit
End If
TextX = TextX & " > """ & WScript.ScriptName & ".log""" & vbCRLF
' WSHShell.Popup TextX, 10, WScript.ScriptName , 64
' WSHShell.run TextX , , True
WSHShell.run TextX , 7, True
TextX = "notepad """ & WScript.ScriptName & ".log"""
WSHShell.run TextX , , True
'***************************************************************
' ENDE - das eigentliche Skript endet
'***************************************************************
' WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende. " , 64
Text = ""
Text = Text & " " & vbCRLF
WScript.Quit
'*********************************
Sub SkriptInfo ' Sub Aufruf
'*********************************
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "ZWEI Dateien (wirklich genau 2 Dateien)" & vbCRLF
Text = Text & "mit der Mouse auf das Skript ziehen und fallen lassen, " & vbCRLF
Text = Text & "oder dem Skript über 'Senden an' die Dateien bzw. " & vbCRLF
Text = Text & "Verzeichnisse übergeben. " & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende." , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & SendToLink & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
#########################################################################
>>> dateienvonheute.vbs <<<
'v3.3*****************************************************
' File: DateienVonHeute.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle Dateien, bei denen das Änderungsdatum
' dem aktuellen Datum entspricht
'*********************************************************
Option Explicit
Dim WSHShell, fso
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, Text, Path
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Path = "d:\setup"
Path = "." ' Verzeichnis, in dem sich das Skript befindet
Path = "c:\temp"
if not fso.FolderExists( Path ) then
MsgBox UCase(Path) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Text = UCase( Path ) & " enthält folgende Dateien von heute:" & vbCRLF
Set oFolders = fso.GetFolder( Path )
Set oFiles = oFolders.Files
For Each i In oFiles
if FormatDateTime( i.DateLastModified ,2) = FormatDateTime( now() ,2) then
Text = Text & i.Name & vbTab & FormatDateTime( i.DateLastModified ,2) & vbCRLF
End If
Next
Set oFiles = nothing
Set oFolders = nothing
MsgBox Text
' i.Path
' i.Name
' i.Type
' i.DateCreated
' i.DateLastAccessed
' i.DateLastModified
' i.Size
#########################################################################
>>> dateierweiterung-1zeichen.vbs <<<
'v3.6*****************************************************
' File: DateiErweiterung-1Zeichen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Ändert von allen Dateien in einem Verzeichnis die
' Dateierweiterung auf 1 Zeichen ( tst.txt ==> tst.t )
'*********************************************************
Option Explicit
Dim WSHShell, fso
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, Text, Pfad, ZielDatei, Datei(), DateiX
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet
Pfad = "c:\test\zw"
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
' Dateiliste
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
ReDim Preserve Datei(i)
Datei(i) = DateiX.Name
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' Dateien umbenennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' For i = LBound(Datei)+1 to UBound(Datei)
For i = 1 to UBound(Datei)
ZielDatei = Pfad & "\" & fso.GetBaseName( Datei(i) ) & "." & Left( fso.GetExtensionName( Datei(i) ), 1)
if UCase( Pfad & "\" & Datei(i) ) = UCase( ZielDatei ) then
Text = Text & Pfad & "\" & Datei(i) & vbTab & " unverändert?!" & vbCRLF
Else
if fso.FileExists ( ZielDatei ) then
if vbYes = MsgBox (" Zieldatei" & vbCRLF & UCase( ZielDatei ) & vbCRLF & "existiert bereits und wird gelöscht!" , 4 , WScript.ScriptName ) then
fso.DeleteFile ZielDatei, True
fso.MoveFile Pfad & "\" & Datei(i) , ZielDatei
Text = Text & Pfad & "\" & Datei(i) & vbTab & " doppel ==> ! " & ZielDatei & vbCRLF
End If
Text = Text & Pfad & "\" & Datei(i) & vbTab & " Zieldatei nicht überschrieben! " & vbCRLF
Else
fso.MoveFile Pfad & "\" & Datei(i) , ZielDatei
Text = Text & Pfad & "\" & Datei(i) & " ==> " & ZielDatei & vbCRLF
End If
End If
Next
' Was angerichtet wurde wird angezeigt:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox "In " & UCase(Pfad) & " wurden folgende Dateien umbenannt:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
Text = ""
WScript.Quit
#########################################################################
>>> dateinamenlangdir.vbs <<<
'v2.6*****************************************************
' File: DateiNamenLangDIR.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverzeichnis nach Dateien, deren Name inkl.
' kompletter Pfadangabe länger als 250 Zeichen ist.
'*********************************************************
Option Explicit
Dim Text, i, iDatei, iVerz, iLang, iAnz, MaxAnz, LaufWerk, Modus1, Modus2, Zeit, TmpTmp
Dim WSHShell, fso, fo, fi
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
iLang = 0
Modus1 = 0
Modus2 = 0
LaufWerk = "c:"
MaxAnz = 200
Text = Text & "Welches Laufwerk soll auf zu lange Dateiennamen (>"
Text = Text & MaxAnz & " Zeichen) getestet werden?"
' Laufwerkauswahl
' ----------------------
LaufWerk = InputBox (Text, WScript.ScriptName, LaufWerk)
If LaufWerk = "" then MsgBox " . . . denn eben nicht!", , WScript.ScriptName
If LaufWerk = "" then WScript.Quit
LaufWerk = UCase(LaufWerk)
' LaufWerk bereit?
' -------------------------------------------------
On Error Resume Next
LaufWerk = fso.GetDrive(LaufWerk).Path
Text = Err.Description
On Error GoTo 0
if not Text = "" then
Text = "Für " & LaufWerk & " gilt:" & vbCRLF & vbCRLF & Text & " !"
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now() & vbCRLF & "Nr." & vbTab & "Länge" & vbTab & "DateiName"
Zeit = now()
TmpTmp = WScript.ScriptName & "_" & fso.GetDrive(LaufWerk).DriveLetter & "_" & ".tmp"
' Prüfen, ob in die DIR-Zieldatei noch geschrieben wird
' -------------------------------------------------
if fso.FileExists( TmpTmp )Then
Text = fso.GetFile( TmpTmp ).Size
wshshell.Popup "Bitte nicht OK drücken!!!" , 3, " Nach 3sek bin ich weg!", vbExclamation
if not Text = fso.GetFile( TmpTmp ).Size Then
MsgBox "Z.Z. wird Laufwerk " & LaufWerk & " noch geprüft."
WScript.Quit
Else
Text = "Laufwerk " & LaufWerk & " wurde bereits geprüft. "
Text = Text & "Soll eine neue DIR-Datei erstellt werden?"
i = MsgBox (Text, 3+32+256, WScript.ScriptName)
If i = vbCancel then WScript.Quit
End If
End If
' MaxAnz festlegen
' -------------------------------------------------
Text = "Dateien mit kompletten Pfad dürfen eine bestimmte Zeichenanzahl nicht übersteigen." & vbCRLF & vbCRLF
Text = Text & "Es sollen alle Dateien mit komplettem Pfad aufgelistet werden, deren Zeichenanzahl folgende Zahl übersteigt:"
MaxAnz = InputBox (Text, WScript.ScriptName, MaxAnz)
If MaxAnz = "" then MsgBox " . . . denn eben nicht!", , WScript.ScriptName
If MaxAnz = "" then WScript.Quit
MaxAnz = CInt(MaxAnz)
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now()
Zeit = now()
' Neue DIR-Zieldatei wird erstellt
' -------------------------------------------------
Text = "%comspec% /c dir " & LaufWerk & "\ /s /b > " & TmpTmp
WSHShell.run Text, 0, True
LogDatei "DIR-End" & vbTab & vbTab & "Dauer" & vbTab & hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & second(Zeit-now())
LogDatei "Nr." & vbTab & "Länge" & vbTab & "DateiName"
' Neue DIR-Zieldatei zum Lesen öffnen
' -------------------------------------------------
if not fso.FileExists( TmpTmp) Then wshshell.Popup "Bitte nicht OK drücken!!!" , 3, " Nach 3sek bin ich weg!", vbExclamation
' Neue DIR-Zieldatei zeilenweise lesen
' -------------------------------------------------
Set fi = FSO.OpenTextFile( TmpTmp, 1, true) ' Datei zum Lesen öffnen
Do While Not (fi.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
iDatei = iDatei +1
Text = fi.Readline
If Len(Text) > MaxAnz Then ' Zeilenlänge zu gross?
iLang = iLang +1
LogDatei iLang & vbTab & len(Text) & vbTab & Text ' protokollieren
End If
Loop
fi.Close
Set fi = Nothing ' Datei schließen
' Text = iDatei & " Dateien auf Laufwerk " & LaufWerk & " wurden überprüft."
Text = iLang & vbTab & "Dateien hatten mehr als " & MaxAnz & " Zeichen." & vbCRLF
Text = Text & iDatei & vbTab & "Dateien/Verzeichnissen auf Laufwerk " & LaufWerk & " wurden überprüft."
' Zeit = hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & secound(Zeit-now())
LogDatei "Nr." & vbTab & "Länge" & vbTab & "DateiName" & vbCRLF & Text
LogDatei "Ende" & vbTab & now() & vbTab & "Dauer" & vbTab & hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & second(Zeit-now())
MsgBox Text, , WSCript.ScriptName
LogDatei "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF
WSHShell.run WScript.ScriptName & "_" & fso.GetDrive(LaufWerk).DriveLetter & "_.log"
' wshshell.Popup "Bitte nicht OK drücken!!!" , 1, " Nach 1sek bin ich weg!", vbExclamation
WSHShell.Sendkeys "^{End}"
WScript.Quit
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & "_" & fso.GetDrive(LaufWerk).DriveLetter & "_.log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> dateinamenlangvbs.vbs <<<
'v3.6*****************************************************
' File: DateiNamenLangVBS.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverzeichnis nach Dateien, deren Name inkl.
' kompletter Pfadangabe länger als 250 Zeichen ist.
'*********************************************************
Option Explicit
Dim TmpTmp, Text, i, iDatei, iVerz, iLang, iAnz, MaxAnz, LaufWerk, Modus1, Modus2, Zeit
Dim WSHShell, fso, fi
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
iLang = 0
Modus1 = 0 ' bei =1 werden kein ZwichenMeldungen ausgegeben
Modus2 = 0 ' bei =1 werden kein ZwichenMeldungen ausgegeben
LaufWerk = "c:"
MaxAnz = 200
Text = Text & "Welches Laufwerk soll auf zu lange Dateiennamen (>"
Text = Text & MaxAnz & " Zeichen) getestet werden?"
' Laufwerkauswahl
' ----------------------
LaufWerk = InputBox (Text, WScript.ScriptName, LaufWerk)
If LaufWerk = "" then MsgBox " . . . denn eben nicht!", , WScript.ScriptName
If LaufWerk = "" then WScript.Quit
LaufWerk = UCase(LaufWerk)
' LaufWerk bereit?
' -------------------------------------------------
On Error Resume Next
LaufWerk = fso.GetDrive(LaufWerk).Path
Text = Err.Description
On Error GoTo 0
if not Text = "" then
Text = "Für " & LaufWerk & " gilt:" & vbCRLF & vbCRLF & Text & " !"
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now() & vbCRLF & "Nr." & vbTab & "Länge" & vbTab & "DateiName"
Zeit = now()
TmpTmp = WScript.ScriptName & "_" & fso.GetDrive(LaufWerk).DriveLetter & "_" & ".tmp"
' Prüfen, ob in die Zieldatei noch geschrieben wird
' -------------------------------------------------
if fso.FileExists( TmpTmp )Then
Text = fso.GetFile( TmpTmp ).Size
wshshell.Popup "Bitte nicht OK drücken!!!" , 3, " Nach 3sek bin ich weg!", vbExclamation
if not Text = fso.GetFile( TmpTmp ).Size Then
MsgBox "Z.Z. wird Laufwerk " & LaufWerk & " noch geprüft."
WScript.Quit
Else
Text = "Laufwerk " & LaufWerk & " wurde bereits geprüft. "
Text = Text & "Soll eine neue Liste erstellt werden?"
i = MsgBox (Text, 3+32+256, WScript.ScriptName)
If i = vbCancel then WScript.Quit
End If
End If
' MaxAnz festlegen
' -------------------------------------------------
Text = "Dateien mit kompletten Pfad dürfen eine bestimmte Zeichenanzahl nicht übersteigen." & vbCRLF & vbCRLF
Text = Text & "Es sollen alle Dateien mit komplettem Pfad aufgelistet werden, deren Zeichenanzahl folgende Zahl übersteigt:"
MaxAnz = InputBox (Text, WScript.ScriptName, MaxAnz)
If MaxAnz = "" then MsgBox " . . . denn eben nicht!", , WScript.ScriptName
If MaxAnz = "" then WScript.Quit
MaxAnz = CInt(MaxAnz)
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now()
Zeit = now()
RecFolder 0, LaufWerk
Text = iLang & vbTab & "Dateien hatten mehr als " & MaxAnz & " Zeichen." & vbCRLF
Text = Text & iDatei & vbTab & "Dateien in " & iVerz & " Verzeichnissen auf Laufwerk " & LaufWerk & " wurden überprüft."
LogDatei "Nr." & vbTab & "Länge" & vbTab & "DateiName" & vbCRLF & Text
LogDatei "Stop" & vbTab & now() & vbTab & "Dauer" & vbTab & hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & second(Zeit-now())
MsgBox Text, , WSCript.ScriptName
LogDatei "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF
WSHShell.run WScript.ScriptName & ".log"
WScript.Sleep 500
WSHShell.Sendkeys "^{End}"
WScript.Quit
' Autor: (c) Günter Born
'*********************************************************
Sub RecFolder (idx, path)
' Rekursive Ordnerbearbeitung (hole Unterordner)
Dim oFolders, oSubFolder, oFolder
' Hole Folders-Auflistung
Set oFolders = fso.GetFolder(path)
Set Fi = oFolders.Files ' Datei-Listung holen
For Each i In Fi ' hole alle Dateien aus Datei-Liste
iDatei = iDatei +1
iAnz = iAnz +1
' If iAnz >= 100 AND Modus2 < 1 Then Modus2 = WSHShell.Popup (iDatei & " Dateien wurden geprüft . . . " & VBCRLF & VBCRLF & "Weiterhin Anzahl der geprüften Dateien anzeigen?", 1, WScript.Scriptname, 1)
if iAnz >= 100 then iAnz = 0
' if iDatei > 2000 then WScript.Quit
Text = path & "\" & oFolders.name & "\" & i.Name
if len(Text) > MaxAnz then
iLang = iLang +1
Text = iLang & vbTab & len(Text) & vbTab & Text
LogDatei Text
If Modus1 < 1 Then Modus1 = WSHShell.Popup (Text & VBCRLF & VBCRLF & "Weiterhin jede zu lange Datei anzeigen?", 1, WScript.Scriptname, 1)
End If
Next
Fi.Close
Set Fi = Nothing ' Datei schließen
Set oSubFolder = oFolders.SubFolders
Redim Preserve Txt(idx) ' redim String-Array
For Each oFolder in oSubFolder ' alle Ordner
iVerz = iVerz +1
' WSHShell.Popup oFolder & " wird geprüft . . . ", 1, WScript.Scriptname
Txt(idx) = Txt(idx) & path & "\" & oFolder.name & vbCRLF
' Unterordner rekursiv suchen
Call RecFolder (idx+1, path & "\" & oFolder.name)
Next
Set oFolders = Nothing ' Variable freigeben
Set oSubFolder = Nothing
End Sub ' RecFolder (idx, path)
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> dateinamespeichern.vbs <<<
'v2.9********************************************************
' File: DateiNameSpeichern.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Mit der Mouse eine Datei / Ordner auf das Skript ziehen und
' der komplette Pfad wird in einer Datei gespeichert . . .
' oder man legt das Skript im "Send To"-Ordner ab und kann
' dann mit der rechten Mouse-Taste die Info speichern.
'************************************************************
Option Explicit
Dim fso, WSHShell, ZielDatei, oArgs, Datei, FileOut, Text
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
ZielDatei = WScript.ScriptName & ".txt"
ZielDatei = "c:\DateiName.txt"
set oArgs = Wscript.Arguments ' hole Argumentsauflistung
If oArgs.Count > 0 Then ' gibt es Argumente?
Datei = oArgs.item(0) ' erstes Argument
Else
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Mouse ein Datei auf das Skript ziehen und" & vbCRLF
Text = Text & "fallen lassen - JETZT werden die Dateiinformationen" & vbCRLF
Text = Text & "in der Datei " & ZielDatei & " gespeichert." & vbCRLF & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
if fso.FileExists(Datei) then
wshshell.Popup fso.GetFile(Datei).Path , 2, WScript.ScriptName, vbExclamation
Set FileOut = fso.OpenTextFile( ZielDatei, 8, true)
fileOut.WriteLine (Datei)
fileOut.Close
Set FileOut = Nothing
End If
if fso.FolderExists(Datei) then
wshshell.Popup Datei , 2, WScript.ScriptName, vbExclamation
Set FileOut = fso.OpenTextFile( ZielDatei, 8, true)
FileOut.WriteLine (Datei)
FileOut.Close
Set FileOut = Nothing
End If
#########################################################################
>>> dateizeilenweiselesenbearbeitenschreiben.vbs <<<
'v3.6*****************************************************
' File: DateiZeilenweiseLesenBearbeitenSchreiben.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Eine (ASCII_) Datei wird zeilenweise in ein Array gelesen,
' das Array bearbeitet und in eine Datei ausggegeben.
'************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird halt das Skript gelesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
i = i + 1
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
Zeile(i) = i+1 & vbTab & Zeile(i)
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.DeleteFile( Datei )
#########################################################################
>>> dateizlbs.vbs <<<
'v3.6*****************************************************
' File: DateiZeilenweiseLesenBearbeitenSchreiben.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Eine (ASCII_) Datei wird zeilenweise in ein Array gelesen,
' das Array bearbeitet und in eine Datei ausggegeben.
'************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird halt das Skript gelesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
i = i + 1
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
Zeile(i) = i+1 & vbTab & Zeile(i)
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.DeleteFile( Datei )
#########################################################################
>>> deltree.vbs <<<
'v3.6*****************************************************
' File: deltree.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Löscht alle Dateien und danach alle Verzeichnisse in
' einem Verzeichnis - vorher werden die Attribute gelöscht.
' Zieht man ein Verzeichnis auf das Skript, werden alle
' enthaltene Dateien und Unterverzeichnisse gelöscht.
' Zieht man eine Datei auf das Skript, wird das Verzeich-
' nis, in dem sich die Datei befindet, ermittelt und wie
' beschrieben gelöscht.
'*********************************************************
Option Explicit
Dim WSHShell, fso, oArgs
Dim i, Text, Pfad
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
If oArgs.Count > 0 Then ' gibt es Argumente?
Pfad = oArgs.item(0) ' erstes Argument
Else ' es gibt keine Argumente!
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Ein Verzeichnis auf das Skript ziehen & fallen lassen" & vbCRLF
Text = Text & ". . . und es wird gelöscht." & vbCRLF & vbCRLF
Text = Text & "Eine Datei auf das Skript ziehen & fallen lassen" & vbCRLF
Text = Text & ". . . und das Verzeichnis, in dem sich die Datei befindet wird gelöscht." & vbCRLF & vbCRLF
Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!"
WSHShell.Popup Text , 30, WScript.ScriptName, 64 + 0
WScript.Quit
End If
if not fso.FolderExists( Pfad ) then
WSHShell.Popup UCase(Pfad) & " entält kein Verzeichnis!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0
WScript.Quit
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SicherheitsAbfrage Pfad ' Sub Aufruf
if DelTree( Pfad ) = true then ' Function Aufruf
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.Popup UCase(Pfad) & " true ist jetzt leer!", 13, WScript.ScriptName, 64 + 0
Else
WSHShell.Popup UCase(Pfad) & " konnte nicht geleert werden!", 30, WScript.ScriptName, 48 + 0
End If
WScript.Quit
'*********************************************************
Function DelTree ( Pfad )
'*********************************************************
Dim fso, oFolders, oSubFolder, oFiles, WSHShell
Dim Text, DateiX, VerzX, Txt
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
DelTree = true
if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad )
' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist
' Datei-Attribute System, Readonly, Hidden zurück setzen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = "%comspec% /c Attrib """ & Pfad & "\*.*"" /S -s -r -h "
WSHShell.run Text, 4, True
' Dateiliste
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
Text = Text & DateiX.Path & vbCRLF
On Error Resume Next
fso.DeleteFile DateiX.Path, True ' True: Löschen erzwingen
if not err.number = 0 then DelTree = False
On Error GoTo 0
Next
Set oFiles = nothing
Set oFolders = nothing
If Text = "" then Text = "keine Dateien vorhanden."
WSHShell.Popup "In " & UCase(Pfad) & " wurden folgende Dateien gelöscht:" & vbCRLF & vbCRLF & Text, 3, WScript.ScriptName, 64 + 0
' Verzeichnisliste
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
Set oFolders = fso.GetFolder( Pfad )
Set oSubFolder = oFolders.SubFolders
For Each VerzX In oSubFolder
Text = Text & VerzX.Path & vbCRLF
On Error Resume Next
fso.DeleteFolder VerzX.Path, True ' True: Löschen erzwingen
if not err.number = 0 then DelTree = False
On Error GoTo 0
Next
Set oFiles = nothing
Set oFolders = nothing
If Text = "" then Text = "keine Unterverzeichnisse vorhanden."
WSHShell.Popup "In " & UCase(Pfad) & " wurden folgende Verzeichnisse gelöscht:" & vbCRLF & vbCRLF & Text, 3, WScript.ScriptName, 64 + 0
Set WSHShell = nothing
Set fso = nothing
End Function ' DelTree
'*********************************************************
'*********************************************************
Sub SicherheitsAbfrage( Pfad ) ' Anfang
'*********************************************************
Text = ""
Text = Text & "Es wird jetzt das Verzeichnis" & vbCRLF & vbCRLF
Text = Text & vbTAB & UCase( Pfad )
Text = Text & vbCRLF & vbCRLF & "unwiederbringlich gelöscht." & vbCRLF & vbCRLF
Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!"
If not vbYes = WSHShell.Popup ( Text , 30, WScript.ScriptName, 48 + 4 + 256 ) then
WSHShell.Popup UCase(Pfad) & vbTab & vbCRLF & vbCRLF & vbTab & "wird nicht gelöscht!" & vbCRLF & vbCRLF & vbTab & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0
WScript.Quit
End if
Text = vbCRLF
Text = Text & "DIE LETZTE WANUNG!" & vbCRLF & vbCRLF
Text = Text & "Es wird jetzt das Verzeichnis" & vbCRLF & vbCRLF
Text = Text & vbTAB & UCase( Pfad )
Text = Text & vbCRLF & vbCRLF & "unwiederbringlich gelöscht - dies betrifft auch Dateien mit " & vbCRLF
Text = Text & "SYSTEM, READONLY- oder HIDDEN-Attributen!" & vbCRLF & vbCRLF
Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!"
If not vbOK = WSHShell.Popup ( Text , 30, WScript.ScriptName, 16 + 1 + 256 ) then
WSHShell.Popup UCase(Pfad) & vbTab & vbCRLF & vbCRLF & vbTab & "wird nicht gelöscht!" & vbCRLF & vbCRLF & vbTab & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0
WScript.Quit
End if
Text = ""
Set fso = nothing
End Sub ' SicherheitsAbfrage
'*********************************************************
#########################################################################
>>> dns-eintragtest.vbs <<<
'v2.A*****************************************************
' File: DNS-EintragTest.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Testet ob ein Gerät über DNS aufgelöst wird.
' Wenn DNS-Einträge nur von Hand in eine DNS-Tabelle
' gesetzt werden, testet dieses Skript, bis eine IP-Adr.
' zurück gegeben wird.
' Zeigt das Skript nur stündlich Ergebnisse, beendet sich
' das Skript, wenn die .log-Datei in .end umbenannt wird.
'*********************************************************
Option Explicit
DIM DefaultGW, Ziel, Text, TextX, Text1, Text2, Button, FileIn, i, x, y, z, MsgTxt, IPtst
Dim Server, Msg, IPSrv
DIM WSHShell, FSO, WSHNet
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Server = "WinNTSRV"
Text = "Von welchem Server soll ermittelt werden, " & vbCRLF
Text = Text & "ob er über WINS oder DNS erreichbar ist?"
Server = UCase(Server)
Server = InputBox (Text, WScript.ScriptName, Server)
If Server = "" then Server = InputBox (Text, WScript.ScriptName)
If Server = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Server = "" then WScript.Quit
Server = UCase(Server)
Ziel = Server & ".tmp"
DefaultGW = ""
' Router / DefaultGateWay festgelegt?
'*********************************************************
GateWayNT ' Sub Aufruf, ob ein DefaultGateWay in der Netz-Config hinterlegt ist
'~~~~~~~~~~~~~~~~~~~~~~
TextX = "Das Netzwerk ist nicht bereit bzw. es ist " & vbCRLF
TextX = TextX & "kein DefaultGateway eingetragen oder erreichbar." & vbCRLF & vbCRLF
TextX = TextX & "DNS-Eintragstest trotzdem ausführen? [OK] nach 15s."
If DefaultGW = "" then
LogDatei (now() & vbTab & Server & " - Default GateWay nicht festgelegt.")
Button = wshshell.Popup( TextX, 15, WScript.ScriptName, 48+1)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
End If
' Router / DefaultGateWay bereit?
'*********************************************************
If not DefaultGW = "" then
IPtst = DefaultGW
IPTest ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~~~~~
if not Text1 = "True" then
wshshell.Popup "Router- / GateWay-Test:" & vbCRLF & DefaultGW & "antwortet nicht." & vbCRLF & vbCRLF & ". . . das ist das ENDE!" , 30, WScript.ScriptName, vbExclamation
LogDatei ( now() & vbTab & Server & " - Default GateWay " & DefaultGW & " antwortet nicht.")
WScript.Quit
End If
End If
' Test ob DNS angelegt ist
'*********************************************************
IPSrv = ""
Msg = "yes"
Do ' Do - Loop bis eine IP-Adr. für den PC (-Name) per WINS/DNS mitgeteilt wird
IPAdr ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~~~~~
' IPAdr. aus WINS / DNS ermitteln
if not IPSrv = "" then Exit Do
LogDatei (now() & vbTab & Server & " - IP-Adr. nicht bekannt.")
Text = "Von dem Server " & UCASE(Server) & vbCRLF
Text = Text & "konnte keine IP-Adr. ermittelt werden. " & vbCRLF & vbCRLF
Text = Text & UCASE(Server) & " erneut testen und jedes Testergebnis anzeigen?" & vbCRLF
Text = Text & "[Ja] nach 15s. [Nein] stündlich Testergebnisse anzeigen."
If "NO" = UCase(Msg) then
i = i + 1
WScript.Sleep 60*1000 ' nur minütlich testen
if i > 58 then ' nur stündlich anzeigen
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "NO"
if Button = vbYes then Msg = "yes"
i = 0
End If
End If
If not "NO" = UCase(Msg) then
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "yes"
if Button = vbNo then Msg = "NO"
i = 0
End If
Loop
Msg = "yes"
Do ' Do - Loop bis der PC (-Name) auf PING antwortet
IPtst = IPSrv
' Antwortet die IP-Adr. ?
IPtest ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~~~~~
If Text1 = "True" then Exit Do
LogDatei (now() & vbTab & Server & " mit IP-Adr. " & IPSrv & " antwortet nicht.")
Text = "Der Server " & UCASE(Server) & " hat die IP-Adr. " & IPSrv & vbCRLF & vbCRLF
Text = Text & "und antwortet auf PING-Anfragen nicht. " & vbCRLF & vbCRLF
Text = Text & UCASE(Server) & " erneut testen und jedes Testergebnis anzeigen?" & vbCRLF
Text = Text & "[Ja] nach 15s. [Nein] stündlich Testergebnisse anzeigen."
' If "NO" = UCase(Msg) then Exit Do
If "NO" = UCase(Msg) then
i = i + 1
WScript.Sleep 60*1000 ' nur menütlich testen
if i > 58 then ' nur stündlich anzeigen
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "NO"
if Button = vbYes then Msg = "yes"
i = 0
End If
End If
If not "NO" = UCase(Msg) then
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "yes"
if Button = vbNo then Msg = "NO"
i = 0
End If
Loop
Text = "Der Server " & vbTab & Server & vbCRLF & "hat die IP-Adr. " & vbTab & IPSrv & vbCRLF
Text = Text & "und beantwortet PING-Anfragen."
MsgBox Text, 64, WScript.ScriptName
LogDatei (now() & vbTab & Server & " mit IP-Adr. " & IPSrv & " antwortet.")
WScript.Quit
'**********************
Sub GateWayNT
'**********************
WshShell.run ("%comspec% /c ipconfig > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
DefaultGW = ""
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(UCase(TextX(i)), "GATEWAY") then
DefaultGW = Mid(TextX(i), InStr(UCase(TextX(i)), ": ") + 1)
DefaultGW = trim(DefaultGW) ' Leerzeichen entfernen
If not 5 < Instr( Instr( (Instr( DefaultGW, "." )+1 ), DefaultGW, ".") +1, DefaultGW, ".") then DefaultGW = ""
' wenn der dritte Punkt (der IP-Adr.) nicht wenigstens an Stelle 6 steht: DefaultGW = ""
End If
next
End Sub ' GateWayNT
'**********************
Sub IPTest
'**********************
' Test ob IP-Adr. erreichbar bereit ist
WshShell.run ("%comspec% /c Ping " & IPtst & " -n 1 -w 500 > " & Ziel),0,true
' PING nur einmal ausführen => nur eine Zeile mit TTL=
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
Text2 = "False"
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text2 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr(Text2, "TTL=") > 1 then
Text1 = "True"
' MsgBox Text2
End If
Loop
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
End Sub ' IPTest
'**********************
Sub IPAdr
'**********************
' IP-Adr. feststellbar?
WshShell.run ("%comspec% /c Ping " & Server & " -n 2 -w 500 > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text1 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr(Text1, "[") AND InStr(Text1, "]") then
IPSrv = Mid( Text1, InStr(Text1, "[") + 1, InStr( Text1, "]" ) - InStr(Text1, "[") -1)
End If
Loop
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
End Sub ' IPAdr
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
if fso.FileExists( WScript.ScriptName & "_" & Server & "_.end" ) then
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & "_" & Server & "_.end", 8, true)
FileOut.WriteLine (LogTxt)
Text = WScript.ScriptName & "_" & Server & "_.end existiert!" & vbCRLF
Text = Text & "--- Skript wird beendet. ---" & vbCRLF
FileOut.WriteLine (Text)
FileOut.Close
Set FileOut = Nothing
Button = wshshell.Popup( Text, 60, WScript.ScriptName, 48)
WScript.Quit
Else
Set FileOut = fso.OpenTextFile( WScript.ScriptName & "_" & Server & "_.log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End If
End Sub ' LogDatei
#########################################################################
>>> druckerauswahl.vbs <<<
'v3.B***********************************************************
' File: DruckerAuswahl.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Bietet eine Auswahl der Netzwerk- bzw. der lokalen Drucker;
' Virtuelle Drucker (PDF) stehen nicht zur Auswahl - das läßt
' sich aber ändern.
'***************************************************************
Option Explicit
Dim Drucker
' WSHShell.run UCase("net use lpt2 /DELETE") , 0, True
' WSHShell.run UCase("net use lpt2: \\PrintSrv\LJ4plus") , 0, True
If Drucker = "" then Drucker = Druckerauswahl ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox Drucker, , WScript.ScriptName
WScript.Quit
'***************************************************************
Function Druckerauswahl ' Anfanfg
'***************************************************************
Dim i, n, Text, DruckerNr, NetPRN, WSHNet
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
n = 0
' welche Drucker sind verwendbar:
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
End If
Next
Text = Text & vbCRLF & "Auf welchen Drucker soll gedruckt werden?"
DruckerNr = InputBox (Text, WScript.ScriptName)
DruckerNr = Asc( DruckerNr ) -48
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
DruckerNr = Asc( DruckerNr ) -48
End If
If DruckerNr > n OR DruckerNr < 1 then DruckerNr = ""
If DruckerNr = "" then WSHShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
If DruckerNr = "" then WScript.Quit
n = 0
' gewählten Drucker ermitteln
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i+1)
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i )
End If
End If
Next
End Function ' Druckerauswahl
'***************************************************************
#########################################################################
>>> druckerliste.vbs <<<
'v2.B********************************************************
' File: DruckerListe.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle Drucker, die am Computer definiert sind
'************************************************************
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
For i = 0 To NetPRN.Count-1 Step 2
TextX = TextX & vbCRLF & " Dr." & (i+2)/2 & vbTab & NetPRN(i) & vbTab & NetPRN(i+1)
Next
MsgBox TextX, , WScript.ScriptName
#########################################################################
>>> exec-hidden-plus.vbs <<<
'v3.A*****************************************************
' File: exec-hidden-plus.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Die ExecHiddenPlus-Function ruft ein weiteres Skript (das
' notfals neu geschrieben wird) auf, welches die Ausgaben
' von Befehlszeilen-Programme (mit DOS-Box) sammelt
'*********************************************************
Option Explicit
' zum Test die nächsten drei Zeilen frei geben
' Dim Tmp
' Tmp = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
MsgBox ExecHiddenPlus ( "%comspec% /c ""C:\PROGRAM FILES\PINGi.EXE"" 127.0.0.1 -n 1" ), , WScript.ScriptName
MsgBox ExecHiddenPlus ( "%comspec% /c Ping RS6663 -n 1" ), , WScript.ScriptName
WScript.Quit
'**************************************************************
Function ExecHiddenPlus ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
Dim FileOut, oWsh, Tmp
Tmp = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
If not WScript.CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
' zum Test nächste Zeile frei geben
' MsgBox Tmp & vbCRLF & "F E H L T"
Set FileOut = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
FileOut.WriteLine( " set oArgs = Wscript.Arguments " )
FileOut.WriteLine( " For i = 0 to oArgs.Count - 1 " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox oArgs.item(i) , , WScript.ScriptName & "" - oArgs "" " )
FileOut.WriteLine( " if Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & """""""" & oArgs.item(i) & """""""" & "" "" " )
FileOut.WriteLine( " if not Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & oArgs.item(i) & "" "" " )
FileOut.WriteLine( " Next " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox CMD , , WScript.ScriptName & "" Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec( CMD ) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ), , WScript.ScriptName & "" Ende "" " )
FileOut.Close
Set FileOuT = nothing
End If
Set oWsh = WScript.CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp & " " & CMD , 0, true
ExecHiddenPlus = oWsh.Environment("volatile")( "Eregbnis" )
' zum Test nächste Zeile frei geben - Löschen der 'Tmp-Datei
WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHiddenPlus ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
#########################################################################
>>> exec-hidden.vbs <<<
'v3.A*****************************************************
' File: exec-hidden.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Die ExecHide-Function ruft ein weiteres Skript (das
' notfals neu geschrieben wird) auf, welches die Ausgaben
' von Befehlszeilen-Programme (mit DOS-Box) sammelt
'*********************************************************
Option Explicit
MsgBox ExecHide ( "%comspec% /c ""C:\PROGRAM FILES\PINGi.EXE"" 127.0.0.1 -n 1" ), , WScript.ScriptName
MsgBox ExecHide ( "%comspec% /c Ping RS6663 -n 1" ), , WScript.ScriptName
WScript.Quit
'**************************************************************
Function ExecHidden ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
Dim FileOut, oWsh, Tmp
CMD = Replace( CMD, """", """""" )
Tmp = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHidden.VBS"
Set FileOut = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox """ & CMD & """ , , WScript.ScriptName & "" - Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec(""" & CMD & """) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ), , WScript.ScriptName & "" - Ende "" " )
FileOut.Close
Set FileOuT = nothing
Set oWsh = WScript.CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp , 0, true
ExecHidden = oWsh.Environment("volatile")( "Eregbnis" )
' zum Löschen der 'Tmp-Datei nächste Zeile frei geben
WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHidden ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
#########################################################################
>>> exec-test.vbs <<<
'v3.A***************************************************
' File: exec-test.vbs
' Autor: dieseyer.de
' dieseyer.de
'
'
'*******************************************************
Option Explicit
Dim WSHShell, fso, FileOut
Dim oExec
Dim input, inputX, i, x, NeueZeit
Dim BatDatei
Dim FSO_PP, FileOut_PP, VBSDatei_PP, Prog_PP
Set Prog_PP = nothing
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
Set WSHShell = WScript.CreateObject("WScript.Shell")
BatDatei = "exec-tst.bat"
DateiErstellen BatDatei ' Function DateiErstellen - Aufruf
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Set oExec = WshShell.Exec( BatDatei )
' Set oExec = WshShell.Exec("%comspec% /c " & BatDatei )
' Set oExec = WshShell.Exec("%comspec% /k " & BatDatei )
Set oExec = WshShell.Exec("%comspec% /c " & BatDatei )
' Start der Anwendung mit der WSHShell.Exec-Methode
i = -1
i = +1
NeueZeit = Hour( DateAdd("h", i, time() ) )
NeueZeit = NeueZeit & ":" & Minute( DateAdd("h", i, time() ) )
' errechnen einer neuen Zeit
' NeueZeit = "8:21"
PopsUp NeueZeit, 20 ' Function PopsUp - Aufruf
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do While True
If Not oExec.StdOut.AtEndOfStream Then
input = input & oExec.StdOut.Read(1)
' Einlesen der Ausgaben der mit der WSHShell.Exec-Methode
' gestarteten Anwendung
If InStr(input, "eben Sie die neue Zeit ein:") <> 0 Then Exit Do
' enthalten die gelesenen Zeichen . . .
' BatDatei hat den 'time'-Befehl ausgeführt
End If
' WScript.Sleep 3
Loop
oExec.StdIn.Write NeueZeit
' übereben der neuen Zeit an die Anwendung, die mit
' der mit der WSHShell.Exec-Methode gestartet wurde
' (es wird automatisch [Enter] mit übergeben)
' (Antwort auf den 'time'-Befehl in der BatDatei)
WScript.Sleep 250
PopsUp "1. Do .. Loop erledigt" & vbCRLF & NeueZeit , 20
WScript.Sleep 300
inputX = ""
Do While True
If Not oExec.StdOut.AtEndOfStream Then
inputX = inputX & oExec.StdOut.Read(1)
' Einlesen der Ausgaben der mit der WSHShell.Exec-Methode
' gestarteten Anwendung
If InStr(inputX, ". . . ") <> 0 Then Exit Do
' enthalten die gelesenen Zeichen . . .
' BatDatei hat den 'pause'-Befehl ausgeführt
End If
Loop
input = input & inputX
PopsUp "2. Do .. Loop erledigt" , 20
' oExec.StdIn.Write VbCrLf
oExec.StdIn.Write "a"
' Antwort auf 'Press any Key . . . '
' (Antwort auf den 'pause'-Befehl in der BatDatei)
inputX = ""
Do While True
If Not oExec.StdOut.AtEndOfStream Then
inputX = inputX & oExec.StdOut.Read(1)
' Einlesen der Ausgaben der mit der WSHShell.Exec-Methode
' gestarteten Anwendung
If InStr(inputX, "- Ende") <> 0 Then Exit Do
' enthalten die gelesenen Zeichen . . .
' BatDatei hat den 'echo ... - Ende'-Befehl ausgeführt
End If
Loop
input = input & inputX
PopsUp "3. Do .. Loop erledigt" , 20
PopsUp "Skript erledigt" , 10
MsgBox vbCRLF & input , , WScript.ScriptName
' **************************************************************
Function PopsUp ( TxT, Dauer ) ' Aufruf v3.7 - http://dieseyer.de
' **************************************************************
' ACHTUNG! Ausserhalb und ver dem ersten Aufruf dieser Prozedur
' muss einmal "Set Prog_PP = nothing" stehen, sonst wird es
' mit dem "prog.terminate" innerhalb der Prozedur nichts!
'
' ACHTUNG! Alle Variablen müssen ausserhalb dieser Prozedur
' deklariert werden (also folgende Zeilen an den Skript-Anafng):
' Dim FSO_PP, FileOut_PP, VBSDatei_PP, Prog_PP
' Set Prog_PP = nothing
'
' Die Vorversion hat (versucht) das PopUp über AppActivate
' zu schließen.
Set Fso_PP = CreateObject("Scripting.FileSystemObject")
' VBSDatei_PP = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
VBSDatei_PP = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
On Error Resume Next
Prog_PP.terminate
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
If Txt = "" then
' On Error Resume Next
IF Fso_PP.FileExists(VBSDatei_PP) then Fso_PP.DeleteFile(VBSDatei_PP) ' löscht das MSG-VBScript
' On Error GoTo 0
Exit Function
End If
Txt = Replace( Txt, vbCRLF, """ & vbCRLF & """ )
Set FileOut_PP = Fso_PP.OpenTextFile(VBSDatei_PP, 2, true) ' MSG-VBScript öffnen mit neu anlegen
FileOut_PP.WriteLine "WScript.CreateObject(""WScript.Shell"").Popup """ & Txt & """ , " & Dauer & ", """ & Fso_PP.GetFileName( VBSDatei_PP ) & " "" "
FileOut_PP.Close
Set FileOut_PP = Nothing
Set Prog_PP = createObject("WScript.Shell").exec( "WScript " & VBSDatei_PP )
Set Fso_PP = Nothing
End Function ' PopsUp v3.7 - http://dieseyer.de
' **************************************************************
' **************************************************************
Function DateiErstellen ( Datei ) ' Aufruf
' **************************************************************
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
FileOut.WriteLine( "time " )
' 1. Do .. Loop - Schleife liest die Ausgaben von "time" aus
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@echo ""doll"" " )
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@echo COMSPEC steht auf: %comspec% " )
FileOut.WriteLine( "dir c:\pr*.* /b " )
FileOut.WriteLine( "@ping 127.0.0.1" )
FileOut.WriteLine( "@echo. " )
FileOut.WriteLine( "@echo X = = = X " )
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@pause" )
' 2. Do .. Loop - Schleife liest die Ausgaben BIS "pause" aus
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@echo %0 - Ende " )
' 3. Do .. Loop - Schleife liest die Ausgaben BIS zu den
' Ausgaben von "@echo %0 - Ende" aus
FileOut.Close
Set FileOuT = nothing
End Function ' DateiErstellen ( BatDatei )
' **************************************************************
#########################################################################
>>> fso-beispielcode.vbs <<<
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' FileSystemObject-Beispielcode
'
' Copyright 1998 Microsoft Corporation. Alle Rechte vorbehalten.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Informationen zur Codequalität:
'
' 1) Der folgende Code führt eine Anzahl von Zeichenfolgenmanipulationen
' aus. Dabei werden kurze Zeichenfolgen mit dem Operator "&" verkettet.
' Da Zeichenfolgenverkettungen lange dauern, ist dieser Code nicht sehr
' effizient. Es ist jedoch ein sehr gängiger Weg zum Schreiben von Code.
' Dieser Weg wird hier verwendet, da dieses Programm intensive Fest-
' plattenoperationen ausführt und diese Operationen wesentlich langsamer
' als die Operationen zum Verketten der Zeichenfolgen im Speicher sind.
' Beachten Sie auch, dass dieser Code zu Demonstrationszwecken geschrieben
' wurde.
'
' 2) Es wird "Option Explicit" verwendet, da der Zugriff auf deklarierte
' Variablen etwas schneller als der Zugriff auf undeklarierte Variablen
' ist. Außerdem wird so das Entstehen von Fehlern im Code verhindert,
' wie z. B. durch den Schreibfehler DriveTypeCDORM statt DriveTypeCDROM.
'
' 3) In diesem Code wurde keine Fehlerbehandlung vorgesehen. Der Code ist
' so besser lesbar. Obwohl Vorkehrungen zum Verhindern von Fehlern in
' normalen Fällen getroffen wurden, können sich Dateisysteme eventuell
' unvorhersehbar verhalten. In kommerziellem Code sollten Sie "On Error
' Resume Next" und das Err-Objekt verwenden, um mögliche Fehler abzufangen.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Einige hilfreiche globale Variablen
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Tabulator
Dim NeueZeile
Const TestLW = "C"
Const TestDateiPfad = "C:\Test"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Von Drive.DriveType zurückgegebene Konstanten
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const DriveTypeWechselbar = 1
Const DriveTypeFest = 2
Const DriveTypeNetzwerk = 3
Const DriveTypeCDROM = 4
Const DriveTypeRAMLW = 5
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Von File.Attributes zurückgegebene Konstanten
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const AttributNormal = 0
Const AttributSchreibgesch = 1
Const AttributVersteckt = 2
Const AttributSystem = 4
Const AttributDatentr = 8
Const AttributVerzeichnis = 16
Const AttributArchiv = 32
Const AttributAlias = 64
Const AttributKomprimiert = 128
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Konstanten zum Öffnen von Dateien
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const DateiOeffnenZumLesen = 1
Const DateiOeffnenZumSchreiben = 2
Const DateiOeffnenZumAnfuegen = 8
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ZeigeLWTyp
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den Laufwerktyp eines angegebenen Drive-Objekts beschreibt.
'
' Zeigt Folgendes
'
' - Drive.DriveType
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ZeigeLWTyp(LW)
Dim S
Select Case LW.DriveType
Case DriveTypeWechselbar
S = "Wechselmedium"
Case DriveTypeFest
S = "Fest"
Case DriveTypeNetzwerk
S = "Netzwerk"
Case DriveTypeCDROM
S = "CD-ROM"
Case DriveTypeRAMLW
S = "RAM-Laufwerk"
Case Else
S = "Unbekannt"
End Select
ZeigeLWTyp = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ZeigeDateiAttribute
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die Datei- oder Ordnerattribute beschreibt.
'
' Zeigt Folgendes
'
' - File.Attributes
' - Folder.Attributes
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ZeigeDateiAttribute(Datei) ' Datei kann Datei oder Ordner sein
Dim S
Dim Attr
Attr = Datei.Attributes
If Attr = 0 Then
ZeigeDateiAttribute = "Normal"
Exit Function
End If
If Attr And AttributVerzeichnis Then S = S & "Verzeichnis "
If Attr And AttributSchreibgesch Then S = S & "Schreibgeschützt "
If Attr And AttributVersteckt Then S = S & "Versteckt "
If Attr And AttributSystem Then S = S & "System "
If Attr And AttributDatentr Then S = S & "Datenträger "
If Attr And AttributArchiv Then S = S & "Archiv "
If Attr And AttributAlias Then S = S & "Alias "
If Attr And AttributKomprimiert Then S = S & "Komprimiert "
ZeigeDateiAttribute = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeLWInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status der verfügbaren Laufwerke beschreibt.
'
' Zeigt Folgendes
'
' - FileSystemObject.Drives
' - Iteration der Drives-Auflistung
' - Drives.Count
' - Drive.AvailableSpace
' - Drive.DriveLetter
' - Drive.DriveType
' - Drive.FileSystem
' - Drive.FreeSpace
' - Drive.IsReady
' - Drive.Path
' - Drive.SerialNumber
' - Drive.ShareName
' - Drive.TotalSize
' - Drive.VolumeName
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeLWInformation(FSO)
Dim LWs
Dim LW
Dim S
Set LWs = FSO.Drives
S = "Anzahl der Laufwerke:" & Tabulator & LWs.Count & NeueZeile & NeueZeile
' Erstellt die erste Zeile des Berichts.
S = S & String(2, Tabulator) & "Laufwerk"
S = S & String(3, Tabulator) & "Datei"
S = S & Tabulator & "Gesamt"
S = S & Tabulator & "Frei"
S = S & Tabulator & "Verfügbar"
S = S & Tabulator & "Seriennummer" & NeueZeile
' Erstellt die zweite Zeile des Berichts.
S = S & "Laufwerkbuchstabe"
S = S & Tabulator & "Pfad"
S = S & Tabulator & "Typ"
S = S & Tabulator & "Bereit?"
S = S & Tabulator & "Name"
S = S & Tabulator & "System"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Nummer" & NeueZeile
' Trennlinie.
S = S & String(105, "-") & NeueZeile
For Each LW In LWs
S = S & LW.DriveLetter
S = S & Tabulator & LW.Path
S = S & Tabulator & ZeigeLWTyp(LW)
S = S & Tabulator & LW.IsReady
If LW.IsReady Then
If DriveTypeNetzwerk = LW.DriveType Then
S = S & Tabulator & LW.ShareName
Else
S = S & Tabulator & LW.VolumeName
End If
S = S & Tabulator & LW.FileSystem
S = S & Tabulator & LW.TotalSize
S = S & Tabulator & LW.FreeSpace
S = S & Tabulator & LW.AvailableSpace
S = S & Tabulator & Hex(LW.SerialNumber)
End If
S = S & NeueZeile
Next
ErzeugeLWInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeDateiInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status einer Datei beschreibt.
'
' Zeigt Folgendes
'
' - File.Path
' - File.Name
' - File.Type
' - File.DateCreated
' - File.DateLastAccessed
' - File.DateLastModified
' - File.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeDateiInformation(Datei)
Dim S
S = NeueZeile & "Pfad:" & Tabulator & Datei.Path
S = S & NeueZeile & "Name:" & Tabulator & Datei.Name
S = S & NeueZeile & "Typ:" & Tabulator & Datei.Type
S = S & NeueZeile & "Attribute:" & Tabulator & ZeigeDateiAttribute(Datei)
S = S & NeueZeile & "Erstellt:" & Tabulator & Datei.DateCreated
S = S & NeueZeile & "Letzter Zugriff:" & Tabulator & Datei.DateLastAccessed
S = S & NeueZeile & "Letzte Änderung:" & Tabulator & Datei.DateLastModified
S = S & NeueZeile & "Größe" & Tabulator & Datei.Size & NeueZeile
ErzeugeDateiInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeOrdnerInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status eines Ordners beschreibt.
'
' Zeigt Folgendes
'
' - Folder.Path
' - Folder.Name
' - Folder.DateCreated
' - Folder.DateLastAccessed
' - Folder.DateLastModified
' - Folder.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeOrdnerInformation(Ordner)
Dim S
S = "Pfad:" & Tabulator & Ordner.Path
S = S & NeueZeile & "Name:" & Tabulator & Ordner.Name
S = S & NeueZeile & "Attribute:" & Tabulator & ZeigeDateiAttribute(Ordner)
S = S & NeueZeile & "Erstellt:" & Tabulator & Ordner.DateCreated
S = S & NeueZeile & "Letzter Zugriff:" & Tabulator & Ordner.DateLastAccessed
S = S & NeueZeile & "Letzte Änderung:" & Tabulator & Ordner.DateLastModified
S = S & NeueZeile & "Größe:" & Tabulator & Ordner.Size & NeueZeile
ErzeugeOrdnerInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeAlleOrdnerInformationen
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status eines Ordners
' und all seiner Dateien und untergeordneten Ordner beschreibt.
'
' Zeigt Folgendes
'
' - Folder.Path
' - Folder.SubFolders
' - Folders.Count
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeAlleOrdnerInformationen(Ordner)
Dim S
Dim UnterOrdnerAuflistung
Dim UnterOrdner
Dim Dateien
Dim Datei
S = "Ordner:" & Tabulator & Ordner.Path & NeueZeile & NeueZeile
Set Dateien = Ordner.Files
If 1 = Dateien.Count Then
S = S & "Es ist 1 Datei vorhanden" & NeueZeile
Else
S = S & "Es sind " & Dateien.Count & "Dateien vorhanden" & NeueZeile
End If
If Dateien.Count <> 0 Then
For Each Datei In Dateien
S = S & ErzeugeDateiInformation(Datei)
Next
End If
Set UnterOrdnerAuflistung = Ordner.SubFolders
If 1 = UnterOrdnerAuflistung.Count Then
S = S & NeueZeile & "Es ist 1 Unterordner vorhanden" & NeueZeile & NeueZeile
Else
S = S & NeueZeile & "Es sind" & UnterOrdnerAuflistung.Count & "Unterordner vorhanden" & NeueZeile & NeueZeile
End If
If UnterOrdnerAuflistung.Count <> 0 Then
For Each UnterOrdner In UnterOrdnerAuflistung
S = S & ErzeugeOrdnerInformation(UnterOrdner)
Next
S = S & NeueZeile
For Each UnterOrdner In UnterOrdnerAuflistung
S = S & ErzeugeAlleOrdnerInformationen(UnterOrdner)
Next
End If
ErzeugeAlleOrdnerInformationen = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeTestInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status des Ordners C:\Test
' und all seiner Dateien und untergeordneten Ordner beschreibt.
'
' Zeigt Folgendes
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.GetFolder
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeTestInformation(FSO)
Dim TestOrdner
Dim S
If Not FSO.DriveExists(TestLW) Then Exit Function
If Not FSO.FolderExists(TestDateiPfad) Then Exit Function
Set TestOrdner = FSO.GetFolder(TestDateiPfad)
ErzeugeTestInformation = ErzeugeAlleOrdnerInformationen(TestOrdner)
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' LoescheTestVerzeichnis
'
' Zweck:
'
' Bereinigt das Testverzeichnis.
'
' Zeigt Folgendes
'
' - FileSystemObject.GetFolder
' - FileSystemObject.DeleteFile
' - FileSystemObject.DeleteFolder
' - Folder.Delete
' - File.Delete
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub LoescheTestVerzeichnis(FSO)
Dim TestOrdner
Dim UnterOrdner
Dim Datei
' Zwei Möglichkeiten, eine Datei zu löschen:
FSO.DeleteFile(TestDateiPfad & "\Beatles\OctopusGarden.txt")
Set Datei = FSO.GetFile(TestDateiPfad & "\Beatles\BathroomWindow.txt")
Datei.Delete
' Zwei Möglichkeiten, einen Ordner zu löschen:
FSO.DeleteFolder(TestDateiPfad & "\Beatles")
FSO.DeleteFile(TestDateiPfad & "\Liesmich.txt")
Set TestOrdner = FSO.GetFolder(TestDateiPfad)
TestOrdner.Delete
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeLiedText
'
' Zweck:
'
' Erstellt mehrere Textdateien in einem Ordner.
'
'
' Zeigt Folgendes
'
' - FileSystemObject.CreateTextFile
' - TextStream.writeLine
' - TextStream.write
' - TextStream.writeBlankLines
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ErzeugeLiedText(Ordner)
Dim TextStream
Set TextStream = Ordner.CreateTextFile("OctopusGarden.txt")
TextStream.write("Octopus' Garden") ' Beachten Sie, dass der Datei kein Zeilenvorschub hinzugefügt wird.
TextStream.WriteLine("(von Ringo Starr)")
TextStream.writeBlankLines(1)
TextStream.writeLine("I'd like to be under the sea, in an octopus' garden in the shade,")
TextStream.writeLine("He'd let us in, knows where we've been - in his octopus' garden in the shade.")
TextStream.writeBlankLines(2)
TextStream.Close
Set TextStream = Ordner.CreateTextFile("BathroomWindow.txt")
TextStream.writeLine("She Came In Through The Bathroom Window (von Lennon/McCartney)")
TextStream.writeLine("")
TextStream.writeLine("She came in through the bathroom window, protected by a silver spoon")
TextStream.writeLine("But now she sucks her thumb and wanders by the banks of her own lagoon")
TextStream.writeBlankLines(2)
TextStream.Close
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' HoleLiedText
'
' Zweck:
'
' Zeigt den Inhalt der Liedtexte an.
'
'
' Zeigt Folgendes
'
' - FileSystemObject.OpenTextFile
' - FileSystemObject.GetFile
' - TextStream.ReadAll
' - TextStream.Close
' - File.OpenAsTextStream
' - TextStream.AtEndOfStream
' - TextStream.ReadLine
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function HoleLiedText(FSO)
Dim TextStream
Dim S
Dim Datei
' Es gibt verschiedene Möglichkeiten, eine Textdatei zu öffnen und die
' Daten dieser Datei zu lesen. Hier sind zwei Möglichkeiten:
Set TextStream = FSO.OpenTextFile(TestDateiPfad & "\Beatles\OctopusGarden.txt", DateiOeffnenZumLesen)
S = TextStream.ReadAll & NeueZeile & NeueZeile
TextStream.Close
Set Datei = FSO.GetFile(TestDateiPfad & "\Beatles\BathroomWindow.txt")
Set TextStream = Datei.OpenAsTextStream(DateiOeffnenZumLesen)
Do While Not TextStream.AtEndOfStream
S = S & TextStream.ReadLine & NeueZeile
Loop
TextStream.Close
HoleLiedText = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeTestVerzeichnis
'
' Zweck:
'
' Erstellt eine Verzeichnishierarchie, um das FileSystemObject-Objekt zu beschreiben.
'
' Die Hierarchie wird in dieser Reihenfolge erstellt:
'
' C:\Test
' C:\Test\Liesmich.txt
' C:\Test\Beatles
' C:\Test\Beatles\OctopusGarden.txt
' C:\Test\Beatles\BathroomWindow.txt
'
'
' Zeigt Folgendes
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.CreateFolder
' - FileSystemObject.CreateTextFile
' - Folders.Add
' - Folder.CreateTextFile
' - TextStream.writeLine
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeTestVerzeichnis(FSO)
Dim TestOrdner
Dim UnterOrdnerAuflistung
Dim UnterOrdner
Dim TextStream
' Bricht ab, wenn (a) das Laufwerk nicht vorhanden oder (b) das zu erstellende Verzeichnis bereits
' vorhanden ist.
If Not FSO.DriveExists(TestLW) Then
ErzeugeTestVerzeichnis = False
Exit Function
End If
If FSO.FolderExists(TestDateiPfad) Then
ErzeugeTestVerzeichnis = False
Exit Function
End If
Set TestOrdner = FSO.CreateFolder(TestDateiPfad)
Set TextStream = FSO.CreateTextFile(TestDateiPfad & "\Liesmich.txt")
TextStream.writeLine("Meine Liedtextsammlung")
TextStream.Close
Set UnterOrdnerAuflistung = TestOrdner.SubFolders
Set UnterOrdner = UnterOrdnerAuflistung.Add("Beatles")
ErzeugeLiedText UnterOrdner
ErzeugeTestVerzeichnis = True
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Die Hauptroutine
'
' Zunächst wird ein Testverzeichnis mit einigen Unterordnern und Dateien erstellt.
' Anschließend werden Informationen über die verfügbaren Festplattenlaufwerke und
' über das Testverzeichnis ausgegeben und danach alles wieder entfernt.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Main
Dim FSO
' Einrichten globaler Daten.
Tabulator = Chr(9)
NeueZeile = Chr(10)
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not ErzeugeTestVerzeichnis(FSO) Then
Ausgabe "Testverzeichnis ist bereits vorhanden oder kann nicht erstellt werden. Fortsetzung nicht möglich."
Exit Sub
End If
Ausgabe ErzeugeLWInformation(FSO) & NeueZeile & NeueZeile
Ausgabe ErzeugeTestInformation(FSO) & NeueZeile & NeueZeile
Ausgabe HoleLiedText(FSO) & NeueZeile & NeueZeile
LoescheTestVerzeichnis(FSO)
End Sub
#########################################################################
>>> hardwareinventur.vbs <<<
'==========================================================================
' VBScript Source File -- Created with SAPIEN Technologies PrimalSCRIPT(TM)
'
' NAME: hardwareinventur.vbs
'
' AUTHOR: Janke,
' DATE : 17.06.2002
'
' COMMENT: Erstellt ein Harwareverzeichnis für die gesamte Domäne
'
' (Nicht von dieseyer@gmx.de geprüft; v3.9.)
'==========================================================================
'**[ DECLARATIONS ]************
CONST ForReading = 1
CONST ForWriting = 2
CONST DEV_ID = 0
CONST FSYS = 1
CONST DSIZE = 2
CONST FSPACE = 3
CONST USPACE = 4
Dim fso, f, fsox, fx, objXL, wmiPath
Dim computerIndex, wscr, adsi, intbutton, strStart
Dim inputFile, outputFile, objKill, strAction, strComplete
Dim strPC, intRow, strFilter, RowNum, strCompName
Dim strSN, strDEV_ID, strFSYS, strDSIZE, strFSPACE, strUSPACE
Dim strRAM, strVir, strPage, strOS, strSP, strProdID, strStatic
Dim strNIC, strIP, strMask, strGate, strMAC, strProc, strSpeed
set adsi = CreateObject("ADSystemInfo")
set wscr = CreateObject("WScript.Network")
Set WshShell = WScript.CreateObject("WScript.Shell")
strDomain = WshShell.ExpandEnvironmentStrings("%USERDOMAIN%")
outputFile = "C:\PC_Inv_NA.txt"
TITLE = WScript.ScriptName
Call KillFile()
set fso = CreateObject("Scripting.FileSystemObject")
' set fsox = CreateObject("Scripting.FileSystemObject")
' set fx = fsox.OpenTextFile(outputFile, ForWriting, True)
set fx = fso.OpenTextFile(outputFile, ForWriting, True)
computerIndex = 1
'******************
'**[ FUNCTIONS ]***************
Function Ask(strAction)
intButton = MsgBox(strAction, vbQuestion + vbYesNo, TITLE)
Ask = intButton = vbNo
End Function
'**[ MAIN SCRIPT ]*************
If Ask("Soll Inventur gestartet werden?") Then
Wscript.Quit
Else
strStart = "Programmstart: " & Date & " at " & time
End If
Call BuildXLS()
Call Connect()
Call Footer()
objXL.ActiveWorkbook.SaveAs "c:\sms.xls"
MsgBox "Programm beendet!", vbInformation + vbOKOnly, TITLE
'******************
Sub Connect()
set ObjDomain = GetObject("WinNT://" + strDomain)
ObjDomain.Filter = Array("Computer")
For each ObjComp in ObjDomain
strPC = ObjComp.name
Call Error()
On Error Resume Next
strCompName = UCase(strPC)
set BIOSSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select SerialNumber from Win32_BIOS")
for each BIOS in BIOSSet
strSN = BIOS.SerialNumber
Next
set MemorySet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select TotalPhysicalMemory, TotalVirtualMemory, TotalPageFileSpace from Win32_LogicalMemoryConfiguration")
for each Memory in MemorySet
strRAM = FormatNumber(Memory.TotalPhysicalMemory/1024,1) & " Mbytes"
strVir = FormatNumber(Memory.TotalVirtualMemory/1024,1) & " Mbytes"
strPage = FormatNumber(Memory.TotalPageFileSpace/1024,1) & " Mbytes"
Next
set OSSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select Caption, CSDVersion, SerialNumber from Win32_OperatingSystem")
for each OS in OSSet
strOS = OS.Caption
strSP = OS.CSDVersion
strProdID = OS.SerialNumber
Next
set IPConfigSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select ServiceName, IPAddress, IPSubnet, DefaultIPGateway, MACAddress from Win32_NetworkAdapterConfiguration where IPEnabled=TRUE")
Count = 0
for each IPConfig in IPConfigSet
Count = Count + 1
Next
ReDim sName(Count - 1)
ReDim sIP(Count - 1)
ReDim sMask(Count - 1)
ReDim sGate(Count - 1)
ReDim sMAC(Count - 1)
Count = 0
for each IPConfig in IPConfigSet
sName(Count) = IPConfig.ServiceName(0)
strNIC = sName(Count)
sIP(Count) = IPConfig.IPAddress(0)
strIP = sIP(Count)
sMask(Count) = IPConfig.IPSubnet(0)
strMask = sMask(Count)
sGate(Count) = IPConfig.DefaultIPGateway(0)
strGate = sGate(Count)
sMAC(Count) = IPConfig.MACAddress(0)
strMAC = sMAC(Count)
Count = Count + 1
Next
set ProSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select Name, MaxClockSpeed from Win32_Processor")
for each Pro in ProSet
strProc = Pro.Name
strSpeed = Pro.MaxClockSpeed
Next
Call Disk_C()
Call Disk_D()
Call Disk_E()
Next ' --- Computer Object
End Sub
Sub BuildXLS()
intRow = 1
Set objXL = Wscript.CreateObject("Excel.Application")
objXL.Visible = True
objXL.WorkBooks.Add
objXL.Rows(1).RowHeight = 40
objXL.Columns(1).ColumnWidth = 14
objXL.Columns(2).ColumnWidth = 15
objXL.Columns(3).ColumnWidth = 7
objXL.Columns(4).ColumnWidth = 7
objXL.Columns(5).ColumnWidth = 11
objXL.Columns(6).ColumnWidth = 11
objXL.Columns(7).ColumnWidth = 11
objXL.Columns(8).ColumnWidth = 12
objXL.Columns(9).ColumnWidth = 12
objXL.Columns(10).ColumnWidth = 12
objXL.Columns(11).ColumnWidth = 32
objXL.Columns(12).ColumnWidth = 13
objXL.Columns(13).ColumnWidth = 24
objXL.Columns(14).ColumnWidth = 10
objXL.Columns(15).ColumnWidth = 12
objXL.Columns(16).ColumnWidth = 12
objXL.Columns(17).ColumnWidth = 12
objXL.Columns(18).ColumnWidth = 17
objXL.Columns(19).ColumnWidth = 24
objXL.Columns(20).ColumnWidth = 7
'*** Set Cell Format for Column Titles ***
objXL.Range("A1:T1").Select
objXL.Selection.Font.Bold = True
objXL.Selection.Interior.ColorIndex = 9
objXL.Selection.Interior.Pattern = 1 'xlSolid
objXL.Selection.Font.ColorIndex = 2
objXL.Selection.WrapText = True
objXL.Columns("A:T").Select
objXL.Selection.HorizontalAlignment = 3 'xlCenter
Call AddLineToXLS("Computer Name","Serial Number","Device ID","File System","Disk Size","Free Space","Used Space","Physical Memory","Virtual Memory","Page File","Operating System","Service Pack","Product ID","Network Card","IP Address","Subnet Mask","Default Gateway","MAC Address","Processor","Speed")
End Sub
Sub AddLineToXLS(strCompName, strSN, strDEV_ID, strFSYS, strDSIZE, strFSPACE, strUSPACE, strRAM, strVir, strPage, strOS, strSP, strProdID, strNIC, strIP, strMask, strGate, strMAC, strProc, strSpeed)
objXL.Cells(intRow, 1).Value = strCompName
objXL.Cells(intRow, 2).Value = strSN
objXL.Cells(intRow, 3).Value = strDEV_ID
objXL.Cells(intRow, 4).Value = strFSYS
objXL.Cells(intRow, 5).Value = strDSIZE
objXL.Cells(intRow, 6).Value = strFSPACE
objXL.Cells(intRow, 7).Value = strUSPACE
objXL.Cells(intRow, 8).Value = strRAM
objXL.Cells(intRow, 9).Value = strVir
objXL.Cells(intRow, 10).Value = strPage
objXL.Cells(intRow, 11).Value = strOS
objXL.Cells(intRow, 12).Value = strSP
objXL.Cells(intRow, 13).Value = strProdID
objXL.Cells(intRow, 14).Value = strNIC
objXL.Cells(intRow, 15).Value = strIP
objXL.Cells(intRow, 16).Value = strMask
objXL.Cells(intRow, 17).Value = strGate
objXL.Cells(intRow, 18).Value = strMAC
objXL.Cells(intRow, 19).Value = strProc
objXL.Cells(intRow, 20).Value = strSpeed
intRow = intRow + 1
objXL.Cells(1, 1).Select
End Sub
Sub AddLineToDisk(strDEV_ID, strFSYS, strDSIZE, strFSPACE, strUSPACE)
objXL.Cells(intRow, 3).Value = strDEV_ID
objXL.Cells(intRow, 4).Value = strFSYS
objXL.Cells(intRow, 5).Value = strDSIZE
objXL.Cells(intRow, 6).Value = strFSPACE
objXL.Cells(intRow, 7).Value = strUSPACE
intRow = intRow + 1
objXL.Cells(1, 1).Select
End Sub
Sub Disk_C()
set DiskSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select DeviceID, FileSystem, Size, FreeSpace from Win32_LogicalDisk where DeviceID = 'C:' and DriveType = '3'")
ReDim strDisk(RowNum,4)
for each Disk in DiskSet
strDisk(RowNum,DEV_ID)= Disk.DeviceID
strDisk(RowNum,FSYS)= Disk.FileSystem
strDisk(RowNum,DSIZE)= FormatNumber(Disk.Size/2^30,1) & " Gbytes"
strDisk(RowNum,FSPACE)= FormatNumber(Disk.FreeSpace/2^30,1) & " Gbytes"
strDisk(RowNum,USPACE)= FormatNumber((Disk.Size-Disk.FreeSpace)/2^30,1) & " Gbytes"
Call AddLineToXLS(strCompName, strSN, strDisk(RowNum,DEV_ID), strDisk(RowNum,FSYS), strDisk(RowNum,DSIZE), strDisk(RowNum,FSPACE), strDisk(RowNum,USPACE), strRAM, strVir, strPage, strOS, strSP, strProdID, strNIC, strIP, strMask, strGate, strMAC, strProc, strSpeed)
Next
End Sub
Sub Disk_D()
set DiskSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select DeviceID, FileSystem, Size, FreeSpace from Win32_LogicalDisk where DeviceID = 'D:' and DriveType = '3'")
On Error Resume Next
ReDim strDisk(RowNum,4)
for each Disk in DiskSet
strDisk(RowNum,DEV_ID)= Disk.DeviceID
strDisk(RowNum,FSYS)= Disk.FileSystem
strDisk(RowNum,DSIZE)= FormatNumber(Disk.Size/2^30,1) & " Gbytes"
strDisk(RowNum,FSPACE)= FormatNumber(Disk.FreeSpace/2^30,1) & " Gbytes"
strDisk(RowNum,USPACE)= FormatNumber((Disk.Size-Disk.FreeSpace)/2^30,1) & " Gbytes"
If IsNull(strDisk(RowNum,FSYS)) Then
Exit Sub
End If
Call AddLineToDisk(strDisk(RowNum,DEV_ID), strDisk(RowNum,FSYS), strDisk(RowNum,DSIZE), strDisk(RowNum,FSPACE), strDisk(RowNum,USPACE))
Next
End Sub
Sub Disk_E()
set DiskSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select DeviceID, FileSystem, Size, FreeSpace from Win32_LogicalDisk where DeviceID = 'E:' and DriveType = '3'")
On Error Resume Next
ReDim strDisk(RowNum,4)
for each Disk in DiskSet
strDisk(RowNum,DEV_ID)= Disk.DeviceID
strDisk(RowNum,FSYS)= Disk.FileSystem
strDisk(RowNum,DSIZE)= FormatNumber(Disk.Size/2^30,1) & " Gbytes"
strDisk(RowNum,FSPACE)= FormatNumber(Disk.FreeSpace/2^30,1) & " Gbytes"
strDisk(RowNum,USPACE)= FormatNumber((Disk.Size-Disk.FreeSpace)/2^30,1) & " Gbytes"
If IsNull(strDisk(RowNum,FSYS)) Then
Exit Sub
End If
Call AddLineToDisk(strDisk(RowNum,DEV_ID), strDisk(RowNum,FSYS), strDisk(RowNum,DSIZE), strDisk(RowNum,FSPACE), strDisk(RowNum,USPACE))
Next
End Sub
Sub KillFile()
Set objKill = CreateObject("Scripting.FileSystemObject")
If (objKill.FileExists("c:\sms.xls")) Then
objKill.DeleteFile("c:\sms.xls")
End If
If (objKill.FileExists("c:\PC_Inv_NA.txt")) Then
objKill.DeleteFile("c:\PC_Inv_NA.txt")
End If
Set objKill = Nothing
End Sub
Sub Footer()
strFooter1 = "Janke, DTC"
strFooter2 = "Script für PC Hardware Inventory"
strComplete = "Progammende : " & Date & " um " & time
intRow = intRow + 5
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strFooter1
intRow = intRow + 1
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strFooter2
intRow = intRow + 1
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strStart
intRow = intRow + 1
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strComplete
intRow = intRow + 1
End Sub
Sub Error()
On Error Resume Next
set CompSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select Name from Win32_ComputerSystem")
If Err Then
fx.WriteLine(strPC)
End If
computerIndex = computerIndex + 1
End Sub
#########################################################################
>>> hdd-test-kopieren.vbs <<<
'v2.C********************************************************
' File: hdd-test-kopieren.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zum Testen der Festplatte bzw. der Datenübertragung (auch
' im Netz) werden Daten aus einem Verzeichnis in ein anderes
' kopiert - die Lesegeschwindigkeit spielt also auch eine
' Rolle.
'************************************************************
' Option Explicit
Dim fso, WSHShell, ShellAppl, Daten, LaufWerk, i, FileOut, Text, TextX
Dim Menge, LwFrei, Nr, ZielVerz, ZielLw, Zeit, Zeit2, MaxTst
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Daten = "C:\copy-tst"
Daten = "C:\cc-tst"
Daten = "C:\temp"
Daten = "C:\DRVS"
Daten = "C:\DRVS"
Daten = "C:\tester"
ZielVerz = "d:\1-tst-"
ZielVerz = "c:\1-tst-"
ZielLw = ""
ZielLw = "V:" ' bei RAM-Disk = V:
ZielLw = ""
MaxTst = 10
LaufWerk = fso.GetDriveName( ZielVerz )
'Wenn ZielLaufWerk doch keine RAM-Disk ist:
' if not FSO.GetDrive(ZielLW).DriveType = 5 then ZielLw = ""
' ZielLw kann eine RAM-Disk sein
If fso.DriveExists(ZielLw) then
if not fso.FolderExists( Daten ) then
wshshell.Popup "Das Verzeichnis " & Daten & " mit den Daten, die kopiert werden sollen, existiert nicht!" , 10, WScript.ScriptName , 32+16
WScript.Quit
End If
' Wenn es das Daten-Verzeichnis gibt, soll es gelöscht werden
' If fso.FolderExists( Left(ZielLw, 2) & Mid(Daten, 3) ) then fso.DeleteFolder(Left(ZielLw, 2) & Mid(Daten, 3) ), true
On Error Resume Next
' Das Daten-Verzeichnis bis zum überquelle füllen
If not fso.FolderExists( Left(ZielLw, 2) & Mid(Daten, 3) ) then
' fso.CopyFolder Daten, Left(ZielLw, 2) & Mid(Daten, 3), True
ShellFolderCopy Daten, Left(ZielLw, 2) & Mid(Daten, 3)
End If
On Error GoTo 0
Daten = Left(ZielLw, 2) & Mid(Daten, 3)
End If
ParamAbfrage ' Function Aufruf
If Len(Daten) < 4 then
wshshell.Popup "Als Quelle für die Daten, die kopiert werden sollen, muss ein Verzeichnis angegeben werden!" , 10, WScript.ScriptName , 32+16
WScript.Quit
End If
if not fso.FolderExists( Daten ) then
wshshell.Popup "Das Verzeichnis " & Daten & " mit den Daten, die kopiert werden sollen, existiert nicht!" , 10, WScript.ScriptName , 32+16
WScript.Quit
End If
Menge = CLng(FormatNumber(fso.GetFolder( Daten ).size/1024/1024, 1))
Text = "Die Dateien im Verzeichnis " & Daten & " (" & Menge & "MB) " & vbCRLF
Text = Text & "werden jetzt " & MaxTst & " mal nach " & ZielVerz & " kopiert " & vbCRLF
Text = Text & "oder bis dort nur noch " & Menge * 2 & " MB frei sind. "
If vbNo = wshshell.Popup (Text , 10, WScript.ScriptName, 32 + 4 ) then
wshshell.Popup " . . . denn eben nicht!" , 10, WScript.ScriptName , 64
WScript.Quit
End If
if not fso.FolderExists(ZielVerz) Then
fso.CreateFolder(ZielVerz)
Zeit = now()
End If
i=0
LogDatei vbCRLF & now()
LogDatei " " & CLng(FormatNumber(fso.GetFolder( Daten ).size /1024/1024, 0)) & "MB von " & Daten & " nach " & ZielVerz
Menge = CLng(FormatNumber(fso.GetFolder( Daten ).size /1024/1024, 0))
Do
LwFrei = CDbl(FormatNumber(fso.GetDrive ( fso.GetDriveName( ZielVerz ) ).FreeSpace/1024/1024, 1))
' genügend Speicher frei?
if LwFrei > (2.00 * Menge) then
if i > 998 then Exit Do
if i > MaxTst - 1 then Exit Do
i = i + 1
nr = i
if Len(CStr(nr)) = 1 then nr = "0" & nr
if Len(CStr(nr)) = 2 then nr = "0" & nr
' if Len(CStr(nr)) = 3 then nr = "0" & nr
Zeit = Zeit - now()
Text = "Durchlauf " & nr & " wird gestartet. - "
Text = Text & Menge & " MB werden nach " & ZielVerz & " kopiert." & vbCRLF & vbCRLF
' Text = Text & "Bisher wurden insgesamt " & CLng(FormatNumber(fso.GetFolder( ZielVerz ).size/1024/1024, 0)) & "MB kopiert."
Text = Text & "Z.Z. sind auf " & fso.GetDriveName( ZielVerz ) & " " & LwFrei & " MB frei. "
if vbcancel = wshshell.Popup (Text , 10, WScript.ScriptName & " - " & CDate(Zeit), 64 + 1 ) then
i = i - 1
Zeit = Zeit + now()
Exit Do
End If
Zeit = Zeit + now()
Kopieren ' Function Kopieren Aufruf
Else
wshshell.Popup i & " Durchläufe absolviert. (" & LwFrei & " MB frei)" , 10, WScript.ScriptName , 64
exit do
End If
Loop
Zeit = CDate( now() - Zeit )
If CDate(Zeit ) < CDate( "00:00:01") then
wshshell.Popup "kleiner als 00:00:01 ist " & CDate(Zeit) , 10, WScript.ScriptName , 64
Zeit = CDate("00:00:01")
End If
Zeit = Second(Zeit) + 60* Minute(Zeit) + 60*60* Hour(Zeit)
TextX = CLng( FormatNumber( fso.GetFolder( ZielVerz ).size/1024/1024, 3))
Zeit = "In " & Zeit & " Sekunden wurden " & TextX & "MB kopiert - das sind ca. " & FormatNumber(TextX / Zeit, 2) & "MB/s. Es ist jetzt " & now()
LogDatei Zeit
Text = i & " mal " & Menge & " MB nach " & ZielVerz & "\xxx kopiert. (" & LwFrei & " MB frei)" & vbCRLF & vbCRLF
Text = Text & "Soll das Testverzeichnis " & ZielVerz & " mit "
Text = Text & TextX & " MB gelöscht werden?" & vbCRLF & vbCRLF
Text = Text & Zeit
If vbNo = wshshell.Popup (Text , 10, WScript.ScriptName, 32 + 4 ) then WScript.Quit
fso.DeleteFolder ZielVerz, True
if fso.FolderExists(ZielVerz) Then wshshell.Popup ZielVerz & " konnte nicht richtig gelöscht werden!" , 60, WScript.ScriptName , 32+16
if not fso.FolderExists(ZielVerz) Then wshshell.Popup ZielVerz & " wurde gelöscht!", 3, WScript.ScriptName
WScript.Quit
'*********************************
Function Kopieren ' Aufruf
'*********************************
Zeit2 = now()
if not fso.FolderExists(ZielVerz & "\" & Nr) Then fso.CreateFolder(ZielVerz & "\" & Nr)
' Text = "%comspec% /c xcopy /S/E " & Daten & "\*.* " & ZielVerz & "\" & Nr & "\*.*"
' WSHShell.run Text, 4, True
' WSHShell.run Text, 0, True
'************************************************************
' fso.CopyFolder Daten, ZielVerz & "\" & Nr, True
' MsgBox Daten & " - " & ZielVerz & "\" & Nr
ShellFolderCopy Daten, ZielVerz & "\" & Nr
Zeit2 = now() - Zeit2
If CDate(Zeit2 ) < CDate( "00:00:01") then Zeit2 = CDate("00:00:01")
Zeit2 = Second(Zeit2) + 60* Minute(Zeit2) + 60*60* Hour(Zeit2)
Text = FormatNumber(fso.GetFolder( ZielVerz & "\" & Nr ).size/1024/1024, 3)
Zeit2 = " " & i & vbTab & Zeit2 & "s " & vbTab & Text & "MB " & vbTab & FormatNumber(Text / Zeit2, 2) & "MB/s " & vbTab & vbTab & now()
LogDatei Zeit2
End Function ' Kopieren
'*********************************
Function ParamAbfrage ' Aufruf
'*********************************
Text = ""
Text = Text & MaxTst & " mal " & vbCRLF
Text = Text & vbTab & "werden die Daten von " & vbCRLF & Daten & vbCRLF
Text = Text & vbTab & "nach " & vbCRLF & ZielVerz & vbCRLF
Text = Text & vbTab & "kopiert - ist das korrekt?"
Text = wshshell.Popup (Text , 20, WScript.ScriptName, 32 + 4 )
If not Text = vbNo Then Exit Function
if not fso.FolderExists( Daten ) then Daten = ""
Daten = InputBox ("Aus welchem Verzeichnis sollen die Daten zum Kopieren verwendet werden?", WScript.ScriptName, Daten )
ZielVerz = InputBox ("In welches Verzeichnis sollen die Daten aus " & Daten & " kopiert werden?", WScript.ScriptName, ZielVerz )
MaxTst = InputBox ("Wie oft (max 999) soll der Kopiervorgang der Daten von " & Daten & " nach " & ZielVerz & " wiederholt werden?", WScript.ScriptName, MaxTst)
ParamAbfrage ' Function Aufruf
End Function ' ParamAbfrage
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & "_" & Left(ZielVerz, 1) & "_ .log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
Set FileOut = Nothing
End Sub ' LogDatei
'*********************************
Sub ShellFolderCopy (Quelle, Ziel) ' Aufruf
'*********************************
' für eine Fortschritsanzeige bei Kopiervorgängen muss: shell32.dll version 4.71 or later
' http://msdn.microsoft.com/library/en-us/shellcc/platform/Shell/reference/objects/folder/copyhere.asp
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME )
Text = "\system32"
If not "Windows_NT" = WScript.CreateObject("WScript.Shell").Environment("Process")("OS") then Text = "\system"
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
Text = fso.GetFileVersion( text ) ' Versionsinfo (der Shell32.dll) holen
' wshshell.Popup "Die Shell32.dll hat die Version " & Text , 3, WScript.ScriptName
Text = Left ( CDbl ( text ), 3 ) ' Versionsinfo formatieren
If Text < 471 then
fso.CopyFolder Quelle, Ziel, True
Else
if not fso.FolderExists( Ziel ) then fso.CreateFolder( Ziel )
Set ShellApp = CreateObject("Shell.Application")
Set oZielOrdner = ShellApp.NameSpace( Ziel )
oZielOrdner.CopyHere Quelle , 16 'vOptions
Set oZielOrdner = nothing
Set ShellApp = nothing
End If
End Sub ' ShellFolderCopy
#########################################################################
>>> historyfavoritesloeschen.vbs <<<
'v2.A*****************************************************
' File: HistoryFavoritesLoeschen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' History- & Favoriten-Verzeichnis loeschen: dazu müssen
' noch die entsprechenden fso.DeleteFolder - Zeilen frei
' gegeben werden
'*********************************************************
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Desktop = Left(WshShell.SpecialFolders("Desktop"), InStrRev(WshShell.SpecialFolders("Desktop"), "\") -1)
' ********** Cookies **********
' C:\WINNT\Profiles\xs30sey\Cookies
' das "Cookies" - Verzeichnis liegt im gleichen Verzeichnis wie andere
' WshSpecialFolders. Z.B. über das "Desktop"-Verzeichnis läßt sich der Pfad aufbauen:
VerzDel = Desktop & "\Cookies"
If fso.FolderExists(VerzDel) Then
Set VerzDel = fso.GetFolder(VerzDel))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """Cookies"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
' ********** Auslagerungsdatei **********
' Folgender Eintrag sorgt dafür, dass die Auslagerungsdatei beim Beenden gelöscht wird.
' So können später dort keine Daten ausgelesen werden.
' [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Memory Management]
' "ClearPageFileAtShutdown"=dword:00000001
' ********** Dokumente 1 **********
' Die Zeichenfolge NoRecentDocsHistory im Registry-Schlüssel
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' hindert Windows am weiteren Mitprotokollieren der zuletzt geöffneten Dokumente.
' Lässt eine bestehende Liste ebenso wie den Menüpunkt 'Dokumente' im Startmenü
' jedoch unberührt (siehe c't 6/02, S.258)
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' NoRecentDocsHistory
' ********** Dokumente 2 **********
' Die Zeichenfolge ClearRecentDocsOnExit im Registry-Schlüssel
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' veranlasst Windows, die Liste der zuletzt geöffneten Dokumente beim nächsten Herunterfahren
' zu löschen. Abmelden reicht nicht, auch der Befehl 'rundll32.exe user,exitwindows' lässt
' die Dokumenten-Liste intakt. Hindert Windows zudem nicht an der weiteren Protokollierung.
' Löscht außerdem die Listen der zuletzt eingegebenen URLs sowie der zuletzt unter AUSFÜHREN
' eingegebenen Befehle.
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' ClearRecentDocsOnExit
' ********** Favoriten **********
' das "Favoriten" - Verzeichnis läßt sich leicht durch das
' WshSpecialFolders - Objekt ermitteln
If fso.FolderExists(WshShell.SpecialFolders("Favorites")) Then
Set VerzDel = fso.GetFolder(WshShell.SpecialFolders("Favorites"))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """Favoriten"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
' ********** Verlauf **********
' das "Verlauf" - Verzeichnis liegt im gleichen Verzeichnis wie andere
' WshSpecialFolders. Z.B. über das "Desktop"-Verzeichnis läßt sich der Pfad aufbauen:
VerzDel = Desktop & "\Verlauf"
If fso.FolderExists(VerzDel) Then
Set VerzDel = fso.GetFolder(VerzDel))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """Verlauf"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
' ********** His6 **********
' Der Verlauf des IE v5.0 liegt (neben Desktop) und heißt bei mir "His6".
' Ich bekommen unter NT4 beim Lösch-Versuch "Erlaubnis verweigert".
' Beim Aufruf über die "Autostart"-Gruppe geht's aber, wenn die MsgBox-
' Zeilen deaktiviert sind.
VerzDel = Desktop & "\His6"
If fso.FolderExists(VerzDel) Then
Set VerzDel = fso.GetFolder(VerzDel))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """His6"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
#########################################################################
>>> ie-start.vbs <<<
'v2.B*****************************************************
' File: ie-start.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Testet ob der Router bereit antwortet - wenn ja, testet
' das Skript, ob ein DNS erreichbar ist - wenn ja, wird
' der InternetExplorer gestartet.
'
' Sinnvoll im HeimNetzwerk, wenn der Router z.B. ein
' #fil14-Disketten-Router mit analogem Modem ist.
'*********************************************************
Option Explicit
DIM DefaultGW, Ziel, Text, TextX, Text1, Text2, Button, FileIn, i, x, y, z, MsgTxt, IPtst
DIM WSHShell, FSO, WSHNet, Env
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Set Env = WSHShell.Environment("PROCESS")
Ziel = "~T~m~p~.tmp"
Ziel = "winipcfg.out"
Const RouterIP = "192.168.150.249"
' Const RouterIP = "192.168.150.126"
' Const RouterIP = "192.168.150.127"
Const DNS1 = "192.76.144.66" ' MSN
Const DNS2 = "195.226.96.131" ' Yello
Const DNS3 = "195.182.96.60" ' VIAG Interkom
DefaultGW = ""
GateWayNT
If DefaultGW = "" then MsgBox "Das Netzwerk ist nicht bereit bzw. " & vbCRLF & "es ist kein DefaultGateway eingetragen.", , WScript.ScriptName
If DefaultGW = "" then WScript.Quit
' Test ob Router bereit ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
z = 0
Do
Z = z + 1
' IPtst = RouterIP
IPtst = DefaultGW
MsgTxt = " " & IPtst & " Test " & z & " erfolglos"
IPTest
if Text1 = "True" then Exit Do
if z < 6 then wshshell.Popup "DefaultGateWay / Router ist nicht bereit!" , 2, MsgTxt, 48
if z > 5 then
Button = wshshell.Popup("DefaultGateWay / Router ist nicht bereit!" , 5, MsgTxt, 37)
if Button = 2 then
wshshell.Popup "Router Test erfolglos und erledigt - das ist das ENDE!" , 2, WScript.ScriptName, vbExclamation
WScript.Quit
End If
End If
Loop
' Test ob DNS? erreichbar bereit ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
z = 2
Do
z = z + 1
x = 1 + z - Int(z / 3) * 3
if x = 1 then IPtst = DNS1
if x = 2 then IPtst = DNS2
if x = 3 then IPtst = DNS3
if x = 1 then MsgTxt = " " & IPtst & "-DNS1 - Test " & z-2 & " erfolglos!"
if x = 2 then MsgTxt = " " & IPtst & "-DNS2 - Test " & z-2 & " erfolglos!"
if x = 3 then MsgTxt = " " & IPtst & "-DNS3 - Test " & z-2 & " erfolglos!"
IPTest
if Text1 = "True" then Exit Do
Button = wshshell.Popup("Internet-Verbindung ist noch nicht bereit!" , 4, MsgTxt, 37)
if Button = 2 then
wshshell.Popup "Internet-Verbindung ist nicht bereit - Test beendet." , 5, WScript.ScriptName, vbExclamation
WScript.Quit
End If
Loop
wshshell.Run "IEXPLORE.EXE"
WScript.Quit
' Test ob IP-Adr. erreichbar bereit ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub IPTest
WshShell.run ("%comspec% /c Ping " & IPtst & " -n 1 -w 500 > " & Ziel),0,true
' PING nur einmal ausführen => nur eine Zeile mit TTL=
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCrLf ,1) ' alles gelesene in Zeilen aufteilen
Text1 = "False"
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(TextX(i), "TTL=") > 1 then Text1 = "True"
next
End Sub
Sub GateWayNT
if Env("OS") = "Windows_NT" then
WSHShell.run "%comspec% /c ipconfig > " & Ziel, 0, True ' ipconfig nach Ziel umleiten
else
WSHShell.run "winipcfg /batch" ,0 ,True ' winipcfg /batch legt autom. "winipcfg.out" an
end if
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(UCase(TextX(i)), "GATEWAY") then
DefaultGW = Mid(TextX(i), InStr(UCase(TextX(i)), ": ") + 1)
DefaultGW = trim(DefaultGW)
End If
next
End Sub
#########################################################################
>>> internettest.vbs <<<
'v3.6***************************************************
' File: InternetTest.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Skript ermittelt, ob das Internet erreichbar ist. Zum
' Testen wird (nur) eine URL benutzt.
'*******************************************************
Option Explicit
Dim oIE
Dim Test, i
Set oIE = CreateObject ("InternetExplorer.Application")
With oIE
' .navigate "http://support.microsoft.com/newsgroups/default.aspx?ICP=GSS3&NewsGroup=microsoft.public.de.german.scripting.wsh&SLCID=DE&scrollnews=m1s9s12"
.navigate "http://google.de"
' .visible = true
.visible = False
do until .readystate=4
wscript.sleep 100
if i > 20 then Exit Do ' entspr. 2sec warten
i = i + 1
loop
Test = .readystate
' If not Test = 4 Then MsgBox "Internet war nicht (schnell genug) erreichbar.", , WScript.Scriptname & " " & Test
' If Test = 4 Then MsgBox "Internet läuft.", , WScript.Scriptname & " " & Test
.quit 'IE wird geschlossen
End with
Set oIE = nothing
If not Test = 4 Then MsgBox "Internet war nicht (schnell genug) erreichbar.", , WScript.Scriptname & " " & Test
If Test = 4 Then MsgBox "Internet läuft.", , WScript.Scriptname & " " & Test
#########################################################################
>>> ip-adresse.vbs <<<
'v2.5***************************************************
' File: ip-dresse.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt den PC-Name und alle IP-Adressen
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = "winipcfg.out"
Set Env = WSHShell.Environment("PROCESS")
if Env("OS") = "Windows_NT" then
WSHShell.run "%comspec% /c ipconfig > " & Ziel, 0, True ' ipconfig nach Ziel umleiten
else
WSHShell.run "winipcfg /batch" ,0 ,True ' winipcfg /batch legt autom. "winipcfg.out" an
end if
set WSHShell = nothing
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
AllIPadr = "Dieser Computer heißt " & wshnet.ComputerName & vbCRLF
AllIPadr = AllIPadr & "und hat folgende IP-Adresse(n): " & vbCRLF & vbCRLF
for i1 = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(UCase(TextX(i1)), "IP-ADRESSE") then ' enthält die akt. Zeile ...
IPadr = ""
IPadr = Mid(TextX(i1), InStr(UCase(TextX(i1)), ": ") + 1) ' alles rechts vom ": "
IPadr = trim(IPadr)
If IPadr <> "" Then AllIPadr = AllIPadr + IPadr ' alle IP-Adr.
' If IPadr <> "" Then Exit For ' nur erste IP-Adr.
End If
next
MsgBox AllIPadr, ,WScript.ScriptName
#########################################################################
>>> ip-ausname.vbs <<<
'v2.5***************************************************
' File: ip-ausname.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt die IP-Adressen aus einem PC-Name
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = "~tmp~.tmp"
PCname = "MeinPC"
PCname = InputBox("Von welchen PC soll die IP-Adr. ermittelt werden?", WScript.ScriptName, PCname)
WSHShell.run ("%comspec% /c Ping " & PCname & " -n 1 -w 500 > " & Ziel), 0, True ' Ping nur einmal ausführen
set WSHShell = nothing
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
for i1 = 0 to ubound(TextX) ' jede Zeile überprüfen
If InStr(UCase(TextX(i1)), "TTL=") Then ' ob TTL= enthalten ist, wenn ja (PING war erfolgreich)
' Bei der Ping-Ausgabe befindet sich hinter der IP-Adresse ein ":" - was links vom ":" steht, ist interessant
EndIPadr = Mid(TextX(i1), 1, InStr(UCase(TextX(i1)), ":") -1 )
' Bei der Ping-Ausgabe befindet sich vor der IP-Adresse ein " " - was rechst vom " " steht, ist die IP-Adr.
IPadr = Mid(EndIPadr, InStrRev(EndIPadr, " ") +1 )
End If
next
if IPadr = "" then MsgBox "Von " & PCname & " konnte die IP-Adr. nicht ermittelt werden!", , WScript.ScriptName
if not IPadr = "" then MsgBox PCname & " hat IP-Adr. " & IPadr , , WScript.ScriptName
#########################################################################
>>> ipnetz-loginscr.vbs <<<
'v2.3*****************************************************
' File: ipnetz-loginscr.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Ermittelt das aktuelle IP-Netz und startet je nach
' Netz ein anderes Script.
'
' Sinnvoll als LoginScript in einem Netz mit mehreren
' IP-Netzen.
'*********************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHEnvX = WSHShell.Environment("Process")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
IPadr1 = "172.21.17." ' IP-Bereich 1
IPadr2 = "192.168.150." ' IP-Bereich 2
IPadr3 = "172.21.19." ' IP-Bereich 3
IPadr4 = "172.21.21." ' IP-Bereich 4
IPadr5 = "10.8.103."
PCname = LCase(wshnet.ComputerName)
Ziel = PCname & ".tmp"
WshShell.run ("%comspec% /c Ping " & PCname & " -n 1 -w 500 > " & Ziel),0,true
' PING nur einmal ausführen
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX,vbCrLf,1) ' alles gelesene in Zeilen aufteilen
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(TextX(i), IPadr1) > 1 then Bereich = "IP1.vbs"
if InStr(TextX(i), IPadr2) > 1 then Bereich = "IP2.vbs"
if InStr(TextX(i), IPadr3) > 1 then Bereich = "IP3.vbs"
if InStr(TextX(i), IPadr4) > 1 then Bereich = "IP4.vbs"
if InStr(TextX(i), IPadr5) > 1 then Bereich = "IP5.vbs"
next
MsgBox Bereich, , WScript.ScriptName
' WshShell.run(Bereich)
#########################################################################
>>> lastlogon.vbs <<<
'v3.4***************************************************
' File: LastLogon.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt den zuletzt angemeldeten Benutzer
'*******************************************************
Option Explicit
Dim WshShell, WSHNet, fso, ObjReg, ObjRemote, KeyX, Text, RootKey, oVal
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
If (fso.FileExists("REGOBJ.DLL")) Then ' Regobj.dll registrieren (erfordert AdminRechte)
Text = "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" ' damit läßt sich besser auf die registry zugreifen
WshShell.Run (Text),,TRUE ' muß im gleichen Verzeichnis wie das Script stehen
Set ObjReg = WScript.CreateObject("RegObj.Registry")
Else
MsgBox "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" & vbTab & " konnte nicht aufgerufen werden!", , WScript.ScriptName
WScript.Quit
End If
Text = "Von welchem Computer soll ermittelt werden, " & vbCRLF
Text = Text & "wer als letzter angemeldet war bzw. aktuell angemeldet ist?"
Text = InputBox (Text, WScript.ScriptName, "PC-Name")
Set ObjRemote = objReg.RemoteRegistry(wshnet.ComputerName) ' Objekt zeigt auf aktuellen PC (REGOBJ.DLL)
Set ObjRemote = objReg.RemoteRegistry( Text ) ' Objekt zeigt auf (Remote-) PC (REGOBJ.DLL)
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\Winlogon"
Text = "Am Computer " & Text & " war zuletzt folgender Benutzer angemeldet:" & vbCRLF & vbCRLF & vbTab & vbTab & vbTab
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
if not err.Number = 0 then Text = Text & " ==> konnte nicht abgefragt werden!"
For Each oVal In RootKey.Values ' Auflistung Werte
if oVal.Name = "DefaultUserName" then
if not oVal.Name = "DefaultUserName" = "" then Text = Text & oVal.Value
End If
Next
On Error GoTo 0
MsgBox " " & Text , , WScript.ScriptName
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
#########################################################################
>>> laufwerkliste.vbs <<<
'v2.9*****************************************************
' File: LaufWerkListe.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle lokalen Laufwerke auf & erstellt Log-Datei.
'*********************************************************
Option Explicit
Dim WshShell, fso, FileOut, DriveList, i, Text1, Text2, Text3
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set DriveList = fso.Drives
' Protokoll in Datei schreiben
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".log", 8, true) ' Datei zum Schreiben öffnen (notfals anlegen)
fileOut.WriteLine(vbCRLF & now() & " Protokoll von " & WScript.ScriptName & ": ")
For Each i in DriveList
if 0 = i.DriveType Then Text1 = "??? " & vbTab & i.DriveLetter & ": " & vbTab
if 1 = i.DriveType Then Text1 = "Disk-Lw." & vbTab & i.DriveLetter & ": " & vbTab
if 2 = i.DriveType Then Text1 = "Festpl. " & vbTab & i.DriveLetter & ": " & vbTab
if 3 = i.DriveType Then Text1 = "Netz-Lw." & vbTab & i.DriveLetter & ": " & vbTab
if 4 = i.DriveType Then Text1 = "CD-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
if 5 = i.DriveType Then Text1 = "RAM-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
If i.IsReady Then
Text3 = ""
Text3 = FormatNumber(i.FreeSpace/1024/1024, 1) & "MB" & vbTab & "von" & vbTab
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?MB" & vbTab & "von" & vbTab
Text3 = ""
Text3 = FormatNumber(i.TotalSize/1024/1024, 1) & "MB" & vbTab & " frei"
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?MB" & vbTab & " frei"
End If
fileOut.WriteLine(Text1)
Text2 = Text2 & Text1 & vbCRLF
Next
FileOut.Close
Set FileOut = Nothing
MsgBox Text2, , WScript.ScriptName
#########################################################################
>>> linkinsendto.vbs <<<
'v3.B***********************************************************
' File: LinkInSendTo.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Befindet sich die Function-Prozedur 'AutoStartLink' in einem
' Skript, wird
'
' beim ersten Aufruf
' - das Skript in den Ordner "c:\programme\dieseyer.de\" kopiert
' - ein Link (mit '-Install'-Parameter) zu diesem Skript im
' Autostart-Ordner (All Users) angelegt, damit nach der
' User-Anmeldung ein Link im (User abhängigen) 'SendTo'
' -Ordner eingefügt wird.
' - ein Link zu diesem Skript im 'SendTo'-Ordner (des zur Zeit
' angemeldeten User) angelegt.
'
' beim Aufruf durch Autostart
' - (mit '-Install'-Parameter) wird ein Link zu diesem Skript im
' 'SendTo'-Ordner (des zur Zeit angemeldeten User) angelegt.
'
' beim Aufruf durch 'Senden an' bzw. 'SendTo':
' Man kann jetzt im Explorer Datei(en) markieren (und dann
' durch Klicken mit der rechten Mouse-Taste und über 'Senden
' an') die markierten Dateien an das Skript übergeben.
'
'***************************************************************
Option Explicit
Dim i, Text, oArgs, SendToLink
' Dim FileOut, Text, Drucker, DruckerNr, Datei, TmpDatei, i
' Set WSHShell = WScript.CreateObject("WScript.Shell")
' Set FSO = CreateObject("Scripting.FileSystemObject")
' Set WSHNet = WScript.CreateObject("WScript.Network")
set oArgs = Wscript.Arguments ' Argumente bereit stellen
SendToLink = "TEST Link In SendToText"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo SendToLink ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then
Text = Left( UCase(oArgs.item(i)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Skript wurde mit Parameter "-S" oder "-I" (bzw. -setup oder -install)
' aufgerufen; die AutoStartLink-Prozedur endet mit WScript.Quit
End If
ReDim Preserve arrTest(i)
arrTest(i) = oArgs.item(i)
Next
' arrSort = bubblesort(arrTest) ' function - Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = "Folgende Argumente wurden an das Skript übergeben:"
for i = 0 to ubound(arrTest)
Text = Text & vbCRLF & vbTab & i+1 & ". Argument: " & arrTest(i)
next
MsgBox Text, , WScript.ScriptName
'***************************************************************
' ANFANG des eigentlichen Skripts
'***************************************************************
'***************************************************************
' ENDE des eigentlichen Skripts
'***************************************************************
WScript.Quit
'***************************************************************
Sub SkriptInfo( SendToLink ) ' Sub Aufruf
'***************************************************************
Dim Text
Dim WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Entweder ein oder mehrere Dateien bzw. Verzeichnisse " & vbCRLF
Text = Text & "mit der Mouse auf das Skript ziehen und fallen lassen, " & vbCRLF
Text = Text & "oder dem Skript über 'Senden an' die Dateien bzw. " & vbCRLF
Text = Text & "Verzeichnisse übergeben. " & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & SendToLink & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
#########################################################################
>>> listservices.vbs <<<
'==========================================================================
'
' AUTHOR: Janke , DTC
' DATE : 08.11.2002
'
' COMMENT: Listet alle Services eines Rechners
'
' (Leicht angepasst von dieseyer@gmx.de; v3.9.)
'==========================================================================
Computername = WScript.CreateObject("WScript.Network").ComputerName
ComputerName = InputBox("Für welchen Rechner?", WScript.ScriptName, ComputerName )
If ComputerName = "" then WScript.Quit
winmgmt1 = "winmgmts:{impersonationLevel=impersonate}!//" & ComputerName
Set ServSet = GetObject( winmgmt1 ).InstancesOf("Win32_service")
LogDatei now()
LogDatei ComputerName & " - Liste aller laufenden Services: "
for each Serv in ServSet
GetObject("winmgmts:").InstancesOf ("win32_service")
Text = Serv.Description & vbCRLF
Text = Text & vbTab & " Executable: " & Serv.PathName & vbCRLF
Text = Text & vbTab & " Status: " & Serv.Status & vbCRLF
Text = Text & vbTab & " State: " & Serv.State & vbCRLF
Text = Text & vbTab & " Start Mode: " & Serv.StartMode & vbCRLF
Text = Text & vbTab & " Start Name: " & Serv.StartName & vbCRLF
LogDatei Text
' MsgBox Text, , WScript.ScriptName
next
LogDatei now()
LogDateiAnzeige
WScript.Quit
'*********************************
Sub LogDatei (LogTxt) ' v3.9
'*********************************
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(WScript.ScriptName & ".log", 8, true).WriteLine (LogTxt)
End Sub ' LogDatei
'*********************************
Sub LogDateiAnzeige ' v3.9
'*********************************
WScript.CreateObject("WScript.Shell").run "notepad " & WScript.ScriptName & ".log"
End Sub ' LogDatei
#########################################################################
>>> mac-adr.vbs <<<
'v3.B***************************************************
' File: MAC-Adr.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' !!! Nur WinNT/2k/XP !!!
'
' gibt die MAC-Adr. der Netzwerkkarten aus
'*******************************************************
Option Explicit
DIM Ziel, Text1, Text2, FileIn
DIM WSHShell, FSO, WSHNet
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = wshnet.ComputerName & ".tmp"
WshShell.run ("%comspec% /c ipconfig /all > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
Text2 = ""
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text1 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr( UCase ( Text1 ) , "HYSI") then ' diese 4 Zeichen sind im engl. und deut. gleich
Text1 = Replace( Text1, vbCR, "")
Text1 = Replace( Text1, vbLF, "")
Text1 = Mid( Text1 , InStrRev( Text1 , " ") )
Text2 = Text2 & Text1 & vbCRLF
End If
Loop
FileIn.Close
Set FileIn = nothing
'folgende Zeile freigeben
'*******************************************************
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
wshshell.Popup Text2 , 15, WScript.ScriptName
WScript.Quit
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & ".log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (now() & vbTab & LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> mp3-bitrate-change.vbs <<<
'v2.4*****************************************************
' File: mp3-bitrate-change.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Wandelt alle mp3-Dateien im aktuellen Ordner in Dateien
' mit einer BitRate von xxx k um.
'
' Dazu am Besten die VBS auf den Desktop (und c:\lame.exe)
' ablegen, den (Windows-) Explorer nicht! im Volbild-Modus
' starten und die Verzeichnisse mit der Mouse auf die VBS
' ziehen und fallen lassen . . .
'
' Die Dateinamen der ALTEN Dateien enden mit ".mp3-"
'*********************************************************
Option Explicit
Dim Song, Artist
Dim Text, Text1, Text2, index, Txt(), i1, i2, newpath
Dim fso, fo, fi, FileOut
Dim LameExe, LameParam, ZielVerz, Ziel, Quelle, WSHShell
Dim oArgs, Verz, BitRate, BitRatOrigMin
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
LameExe = "c:\lame.exe"
If not (fso.FileExists(LameExe)) Then
MsgBox """" & UCase(LameExe) & """ nicht vorhanden!", , WScript.ScriptName
WScript.Quit
End If
BitRate = 128
set oArgs = Wscript.Arguments ' hole Argumentsauflistung
If oArgs.Count > 0 Then ' Ja, hole Name
Verz = """" & oArgs.item(0) & """" ' erster Parameter
Verz = oArgs.item(0) ' erster Parameter
Else
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Mouse ein Verzeichnis mit mp3-Dateien" & vbCRLF
Text = Text & "auf das Skript ziehen und fallen lassen - JETZT" & vbCRLF
Text = Text & "werden alle gefundenen mp3-Dateien in Dateien " & vbCRLF
Text = Text & "mit " & BitRate & "k BitRate um-en-codiert. Die ALTEN Dateien" & vbCRLF
Text = Text & "enden dann mit "".mp3- . . . """ & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
BitRate = InputBox ("In welche Bitrate sollen die mp3-Dateien" & vbCRLF & vbCRLF & "gewandelt werden?", WScript.ScriptName, BitRate)
If Bitrate = "" then WScript.Quit
i2 = 0
Text = ""
Set fo = fso.GetFolder(Verz)
Set fi = fo.Files ' Datei-Auflistung holen
For Each i1 In fi ' hole Liste aller Dateien
if Ucase(Right(i1.name,4)) = ".MP3" then ' hole nur mp3 - Dateien
Quelle = Verz & "\" & i1.Name & "-"
Ziel = Verz & "\" & i1.Name
if fso.FileExists(Ziel) then ' wenn es eine .mp3- - Datei
if fso.GetFile(Ziel).Size = 0 then ' mit 0 Byte Größe gibt
fso.DeleteFile(Ziel), True ' wird diese gelöscht
WSHShell.Popup "0 Byte große Datei " & Ziel & " wurde gelöscht", 3, WScript.ScriptName
End If
End If
if not fso.FileExists(Quelle) then
Set Text1 = fso.GetFile(Ziel)
Text1.Move Quelle
End If
if not fso.GetFile(Quelle).Size < fso.GetDrive(Left(Quelle,3)).AvailableSpace then
MsgBox "Auf " & Verz & " steht nicht genügend Platz zur Verfügung!", , WScript.ScriptName
WScript.Quit ' wenn weniger als die Größe der Quelle-Datei auf
End If ' dem Ziellaufwerk frei ist - Abbruch
if not FSO.FileExists(Ziel) then ' wenn es noch keine -??????.mp3-Datei gibt
' LameParam = "cmd /k " & LameExe & " -b " & BitRate & " -h --mp3input """ & Quelle & """ """ & Ziel & """"
LameParam = LameExe & " -b " & BitRate & " -h --mp3input """ & Quelle & """ """ & Ziel & """"
WSHShell.Run LameParam , , True
i2 = i2+1
Text = Text & "(" & i2 & ") " & vbTab & "... ~" & Ziel & vbCRLF
End If
End If
Next
Set fo = Nothing ' Datei schließen
If i2 = 0 then Text = "Es wurden keine Dateien zum Wandeln gefunden."
If i2 > 0 then Text = Verz & vbCRLF & vbCRLF & "enthält folgende mp3-Dateien mit " & BitRate & "k-BitRate:" & vbCRLF & vbCRLF & Text
Set FileOut = fso.OpenTextFile(Verz & "\" & WScript.ScriptName & ".log", 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
fileOut.WriteLine (Now() & " " & Text)
fileOut.Close
Set FileOut = Nothing ' Datei schließen
MsgBox Text, , WScript.ScriptName
#########################################################################
>>> netzlaufwerkedetails.vbs <<<
'v2.5*****************************************************
' File: NetzLaufWerkeDetails.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' zeigt Netzlaufwerk mit zugeordnetem Laufwerksbuchstaben
'*********************************************************
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNetzWerk = WScript.CreateObject("WScript.NetWork")
Set WSHLaufWerk = WSHNetzWerk.EnumNetworkDrives()
TextX = "Liste der Netzwerlaufwerke:" & vbCRLF
For i = 0 To WSHLaufWerk.Count -1 Step 2
TextX = TextX & vbCRLF ' neue Zeile
TextX = TextX & i & vbTab
if WSHLaufWerk.Item(i) <> "" Then
TextX = TextX & WSHLaufWerk.Item(i) & vbTab
TextX = TextX & fso.getDrive(WSHLaufWerk.Item(i)).ShareName
End If
Next
MsgBox TextX, , WScript.ScriptName
#########################################################################
>>> netzverb-zu-server.vbs <<<
'v2.6*****************************************************
' File: netzverb-zu-server.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Netzlaufwerk verbinden mit einem anderen UserName, als
' der, der am System (Domain) gerade angemeldet ist.
'*********************************************************
Option Explicit
DIM WSHShell, WSHNetzWerk, WSHLaufWerk, FSO, AllDrives
DIM Titel, Fehler, FehlerNr
DIM LogonName, LogonPwd, Server, ServerIP, ServerDomain
DIM FileIn, FileOut
DIM TmpTxt, TextX, i, LW, FGN, IPadr, EndIPadr
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHNetzWerk = WScript.CreateObject("WScript.NetWork")
Set WSHLaufWerk = WSHNetzWerk.EnumNetworkDrives()
Set FSO = CreateObject("Scripting.FileSystemObject")
ServerDomain = "ALLIANZ\SERVER-"
LogonName = "Maier"
LogonName = WSHNetzWerk.UserName
TmpTxt = "~tmp~.tmp"
Titel = WScript.ScriptName
Server = "ServerXYZ" ' Ziel-Server
LW = "W:" ' LaufWerksBuchstaben, die verwendet werden sollen
FGN = "C$" ' FreiGabeName auf dem Ziel-Server
FGN = "IPC$" ' FreiGabeName auf dem Ziel-Server
FGN = "d$" ' FreiGabeName auf dem Ziel-Server
LogDatei vbCRLF & now() ' LogDatei SUB-Aufruf
' Server erfragen
' ~~~~~~~~~~~~~~~
TextX = "An welchen Server wollen Sie sich an anmelden?"
Server = InputBox (TextX, Titel, Server)
Server = UCase(Server)
If Server = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
ServerIP = ""
ServerTesten ' ServerTesten SUB-Aufrufen
' ~~~~~~~~~~~~~~~ ' ermittelt IPadr. aus DNS-Name
' Die Verbindung von Netzlaufwerken klappt m.E. per IP-Adresse besser bzw. fast immer
If ServerIP = "" Then
TextX = Server & vbCRLF & vbCRLF & "ist nicht per PING erreichbar!"
LogDatei TextX
MsgBox TextX, , Titel
WScript.Quit
End If
' FGN erfragen
' ~~~~~~~~~~~~
TextX = "Welcher Freigabenamen auf " & vbCRLF & vbCRLF & """ \\" & UCase(Server) & "\ "" soll verwendet werden?"
FGN = InputBox (TextX, Titel, FGN)
If FGN = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
' LW erfragen
' ~~~~~~~~~~~
LW = ""
If not UCase(FGN) = "IPC$" then
TextX = "Welchen Laufwerksbuchstaben soll die Verbindung zu " & vbCRLF & vbCRLF & """ \\" & UCase(Server) & "\" & FGN & """ verwenden?"
TextX = TextX & vbCRLF & vbCRLF & "( "
For i = 0 To WSHLaufWerk.Count -1 Step 2
if WSHLaufWerk.Item(i) <> "" Then
TextX = TextX & WSHLaufWerk.Item(i) & " "
End If
Next
TextX = TextX & vbCRLF & "werden bereits verwendet.) " & vbCRLF
LW = "W:"
LW = InputBox (TextX, Titel, LW)
If LW = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
End If
' LogonName erfragen
' ~~~~~~~~~~~~~~~~~~
TextX = "Das Ganze funktioniert nur, wenn die Passwörter synchron sind!" & vbCRLF & vbCRLF
TextX = TextX & "Mit welchem Namen wollen Sie sich an " & Server & " bzw. " & ServerIP & " anmelden?"
' Domäne\UserName
LogonName = InputBox (TextX, Titel, ServerDomain & LogonName)
LogonName = UCase(LogonName)
If LogonName = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
' Trennen
' ~~~~~~~
LWtrennen FGN ' LWtrennen SUB-Aufruf
' Verbinden
' ~~~~~~~~~
LWverbinden LW, FGN ' LWverbinden SUB-Aufruf
WSHShell.Popup (". . . erledigt!"), 3, Titel, 64
WScript.Quit
'*********************************
Function LWtrennen(LW)
'*********************************
if FSO.DriveExists(LW) then ' LaufWerk vorhanden?
if FSO.GetDrive(LW).DriveType = 3 then ' ist es NetzLaufWerk?
For i = 2 To WSHLaufWerk.Count -1 Step 2
If WSHLaufWerk.Item(i) = LW Then TextX = fso.getDrive(WSHLaufWerk.Item(i)).ShareName
Next
TextX = LW & " ist mit " & TextX & " verbunden " & vbCRLF & vbCRLF
TextX = TextX & "und wird jetzt getrennt - stimmt's ? "
i = MsgBox(TextX, 4+32+256, Titel)
if i = 6 then WSHNetzWerk.RemoveNetWorkDrive LW ' NetzLaufWerk trennen
End If
End If
End Function ' LWtrennen(LW)
'*********************************
Function LWverbinden(LW, FGN)
'*********************************
On Error Resume Next ' fals es nicht klappt
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.RemoveNetworkDrive "\\" & ServerIP, true '
FehlerNr = Err.Number
Fehler = Err.Description
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & ServerIP
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.RemoveNetworkDrive \\" & ServerIP
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.RemoveNetworkDrive "\\" & Server, true '
FehlerNr = Err.Number
Fehler = Err.Description
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & Server
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.RemoveNetworkDrive \\" & Server
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.MapNetWorkDrive LW, "\\" & Server & "\" & FGN, , LogonName
FehlerNr = Err.Number
Fehler = Err.Description
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & Server & "\" & FGN
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.MapNetWorkDrive LW, \\" & Server & "\" & FGN & " " & LogonName
If FehlerNr = 13 then
WSHShell.Popup "Verbinden mit " & "\\" & Server & "\" & FGN & " war erfolgreich (UserName: " & LogonName & ")", 3, Titel, 64
End If
If not FehlerNr = 13 then
WSHShell.Popup Fehler & vbCRLF & ". . . beim Verbinden mit " & "\\" & Server & "\" & FGN & " (UserName: " & LogonName & ")" & vbCRLF & vbCRLF & "Es wird jetzt über IP versucht!", 3, Titel, 64
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.MapNetWorkDrive LW, "\\" & ServerIP & "\" & FGN, , LogonName
Fehler = Err.Description
FehlerNr = Err.Number
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & ServerIP & "\" & FGN
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.MapNetWorkDrive LW, \\" & ServerIP & "\" & FGN & " " & LogonName
End If
On Error GoTo 0
If not FehlerNr = 13 then
WSHShell.Popup Fehler & vbCRLF & ". . . beim Verbinden mit " & "\\" & ServerIP & "\" & FGN & " (UserName: " & LogonName & ")" , , WScript.ScriptName
End If
If FehlerNr = 13 then
WSHShell.Popup "Verbinden mit " & "\\" & ServerIP & "\" & FGN & " war erfolgreich (UserName: " & LogonName & ")", 3, Titel, 64
End If
' If not Fehler = "" then MsgBox Fehler & vbCRLF & ". . . beim Verbinden mit " & FGN & " (UserName: " & LogonName & ")", , WScript.ScriptName
' If Fehler = "" then WSHShell.Popup ("Verbinden mit " & FGN & " war erfolgreich (UserName: " & LogonName & ")"), 3, Titel, 64
End Function ' LWverbinden
'*********************************
Sub ServerTesten
'*********************************
if fso.FileExists(TmpTxt) Then fso.DeleteFile(TmpTxt), True ' Datei löschen
if fso.FileExists(TmpTxt) Then wshshell.Popup "Bitte nicht OK drücken!!!" , 3, " Nach 3sek bin ich weg!", vbExclamation
if fso.FileExists(TmpTxt) Then MsgBox TmpTxt & " konnte nicht gelöscht werden - ABBRUCH", , Titel
if fso.FileExists(TmpTxt) Then WScript.Quit
WSHShell.run ("%comspec% /c Ping " & Server & " -n 1 -w 500 > " & TmpTxt), 0, True ' Ping nur einmal ausführen
Set FileIn = fso.OpenTextFile(TmpTxt, 1, true) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(TmpTxt) Then fso.DeleteFile(TmpTxt), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
If InStr(UCase(TextX(i)), "TTL=") Then ' ob TTL= enthalten ist, wenn ja (PING war erfolgreich)
' Bei der Ping-Ausgabe befindet sich hinter der IP-Adresse ein ":" - was links vom ":" steht, ist interessant
ServerIP = Mid(TextX(i), 1, InStr(UCase(TextX(i)), ":") -1 )
' Bei der Ping-Ausgabe befindet sich vor der IP-Adresse ein " " - was rechst vom " " steht, ist die IP-Adr.
ServerIP = Mid(ServerIP, InStrRev(ServerIP, " ") +1 )
End If
next
End Sub ' ServerTesten
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".log", 8, true)
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> ordnerauswahl.vbs <<<
'v3.9*****************************************************
' File: OrdnerAuswahl.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Nach einem Beitrag von Th. Gudera in der MS-NG
'*********************************************************
dialog = BrowseForFolder("Wählen Sie das Verzeichnis",&h1, 0)
msgbox dialog, , WScript.ScriptName
' *********************************************************
Function BrowseForFolder(strPrompt, BrowseInfo, root) ' Start
' *********************************************************
Dim objShell, objFolder, intColonPos, objWshShell
Set objWshShell = CreateObject("WScript.Shell")
' In der Folgezeile gibt's eine Fehlermeldung, wenn
' die Shell32.dll nicht v4.71 oder höher ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&h0&, strPrompt, BrowseInfo, root)
' On Error Resume Next
BrowseForFolder = objFolder.ParentFolder.ParseName(objFolder.Title).Path
If Err.Number <> 0 Then
BrowseForFolder = Null
If objFolder.Title = "Desktop" Then
BrowseForFolder = objwshshell.SpecialFolders("Desktop")
End If
intColonPos = InStr(objFolder.Title, ":")
If intColonPos > 0 Then
BrowseForFolder = Mid(objFolder.Title, intColonPos - 1, 2) & "\"
End If
End If
Set objShell = nothing
Set objWshShell = nothing
Set objFolder = nothing
End Function ' BrowseForFolder(strPrompt, BrowseInfo, root)
' *********************************************************
#########################################################################
>>> pc-aus-w9x.vbs <<<
'v2.3*****************************************************
' File: pc-aus-w9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' 1. Scandisk über alle Laufwerke
' 2. Defragmetierung über alle Laufwerke
' 3. ShutDown mit Ausschalten
'*********************************************************
Option Explicit
DIM WshShell, OpSys, RegKey, TextX, ZielSys, NT_9x, Text
Set WshShell = WScript.CreateObject("WScript.Shell")
' ----------------------------------------------
' Testen der Windows-Version (XP nicht getestet)
' ----------------------------------------------
OpSys = ""
' Win9x/ME?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows\CurrentVersion\Productname")
End if
On Error GoTo 0
If not OpSys = "" Then
WshShell.Run "scandskw /allfixeddisks /noninteractive /silent",,True
WshShell.Run "defrag /all /f /p /noprompt",,True
' Neustart
' WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 7"
' Ausschalten
WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 13"
WScript.Quit
End If
' WinNT?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = "Windows NT " & WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
End if
On Error GoTo 0
' Win2k?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\Productname")
End if
On Error GoTo 0
MsgBox OpSys & " wird nicht unterstützt.", , WScript.ScriptName
#########################################################################
>>> pc-restart-w9x.vbs <<<
'v2.3*****************************************************
' File: pc-restart-w9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' 1. Scandisk über alle Laufwerke
' 2. Defragmetierung über alle Laufwerke
' 3. ShutDown mit Neustart
'*********************************************************
Option Explicit
DIM WshShell, OpSys, RegKey, TextX, ZielSys, NT_9x, Text
Set WshShell = WScript.CreateObject("WScript.Shell")
' ----------------------------------------------
' Testen der Windows-Version (XP nicht getestet)
' ----------------------------------------------
OpSys = ""
' Win9x/ME?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows\CurrentVersion\Productname")
End if
On Error GoTo 0
If not OpSys = "" Then
WshShell.Run "scandskw /allfixeddisks /noninteractive /silent",,True
WshShell.Run "defrag /all /f /p /noprompt",,True
' Neustart
WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 7"
' Ausschalten
' WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 13"
WScript.Quit
End If
' WinNT?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = "Windows NT " & WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
End if
On Error GoTo 0
' Win2k?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\Productname")
End if
On Error GoTo 0
MsgBox OpSys & " wird nicht unterstützt.", , WScript.ScriptName
#########################################################################
>>> pcmitdhcp.vbs <<<
'v2.A***************************************************
' File: PCmitDHCP.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' !!! Nur WinNT/2k/XP !!!
'
' Testet, ob ein PC mit oder ohne DHCP arbeitet.
' Wird das Skript im LoginScript aufgerufen, gibt die
' LOG-Datei eine übersicht zu allen PC's.
'*******************************************************
Option Explicit
DIM Ziel, Text1, Text2, FileIn
DIM WSHShell, FSO, WSHNet
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = wshnet.ComputerName & ".tmp"
WshShell.run ("%comspec% /c ipconfig /all > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1, true) ' Datei zum Lesen öffnen
Text2 = "kein DHCP"
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text1 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr( UCase ( Text1) , "DHCP") then
if InStr( UCase ( Text1) , "JA") then Text2 = "DHCP"
if InStr( UCase ( Text1) , "YES") then Text2 = "DHCP"
End If
Loop
FileIn.Close
Set FileIn = nothing
If Text2 = "DHCP" then LogDatei wshnet.ComputerName & vbTab & "dyn. IP-Adr. / verwendet DHCP"
If not Text2 = "DHCP" then LogDatei wshnet.ComputerName & vbTab & "stat. IP-Adr."
'folgende Zeile freigeben
'*******************************************************
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
wshshell.Popup "PC " & wshnet.ComputerName & " verwendet " & Text2 , 15, WScript.ScriptName
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & ".log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (now() & vbTab & LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> popsup.vbs <<<
'v3.7***************************************************
' File: PopsUp.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Function PopsUp ( TxT, Dauer )
' erstellt ein MSG-VBScript im %TEMP%-Verzeichnis und
' ruft es mit WSHShell.Exec auf.
' Dadurch ist es beim Erneuten Aufruf des MSG-VBscripts
' möglich, das "alte" PopUp (vor Zeitablauf) zu beenden.
'*******************************************************
Option Explicit
Dim i
Dim FSO_PP, FileOut_PP, VBSDatei_PP, Prog_PP
Set Prog_PP = nothing
For i = 1 to 7 Step 2
WScript.Sleep i*500
PopsUp "Hallo" & vbTab & i, 20
next
PopsUp "" , 0 ' zum löschen des letzten PopsUp
' **************************************************************
Function PopsUp ( TxT, Dauer ) ' Aufruf v3.7 - http://dieseyer.de
' **************************************************************
' ACHTUNG! Ausserhalb und ver dem ersten Aufruf dieser Prozedur
' muss einmal "Set Prog_PP = nothing" stehen, sonst wird es
' mit dem "prog.terminate" innerhalb der Prozedur nichts!
'
' ACHTUNG! Alle Variablen müssen ausserhalb dieser Prozedur
' deklariert werden (also folgende Zeilen an den Skript-Anafng):
' Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
' Set Prog_PP = nothing
'
' Die Vorversion hat (versucht) das PopUp über AppActivate
' zu schließen.
Set Fso_PP = CreateObject("Scripting.FileSystemObject")
' VBSDatei_PP = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
VBSDatei_PP = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
On Error Resume Next
Prog_PP.terminate
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
If Txt = "" then
' On Error Resume Next
IF Fso_PP.FileExists(VBSDatei_PP) then Fso_PP.DeleteFile(VBSDatei_PP) ' löscht das MSG-VBScript
' On Error GoTo 0
Exit Function
End If
Txt = Replace( Txt, vbCRLF, """ & vbCRLF & """ )
Set FileOut_PP = Fso_PP.OpenTextFile(VBSDatei_PP, 2, true) ' MSG-VBScript öffnen mit neu anlegen
FileOut_PP.WriteLine "WScript.CreateObject(""WScript.Shell"").Popup """ & Txt & """ , " & Dauer & ", """ & Fso_PP.GetFileName( VBSDatei_PP ) & " "" "
FileOut_PP.Close
Set FileOut_PP = Nothing
Set Prog_PP = createObject("WScript.Shell").exec( "WScript " & VBSDatei_PP )
Set Fso_PP = Nothing
End Function ' PopsUp v3.7 - http://dieseyer.de
' **************************************************************
#########################################################################
>>> programmauswahl.vbs <<<
'v3.8********************************************************
' File: programmauswahl.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Wechselt zwischen 2 Programmen, von denen immer eines
' gestartet sein soll.
'************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Text, Prog, Prog1, Prog2, ProgExec, MsgIcon
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' erstes Programm festlegen
Prog1 = "C:\Programme\Windows NT\Zubehör\WORDPAD.EXE"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' gibt es das erstes Programm nicht, ein anders festlegen
if not fso.FileExists( Prog1 ) then Prog1 = "C:\Programme\Zubehör\WORDPAD.EXE"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' gibt es das erstes Programm nicht ==> Programmende
if not fso.FileExists( Prog1 ) then
MsgBox Prog1 & vbCRLF & " existiert nicht. Das ist das Ende."
WScript.Quit
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' zweites Programm festlegen
Prog2 = "C:\WINNT\system32\CALC.EXE"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' gibt es das zweite Programm nicht ==> Programmende
if not fso.FileExists( Prog2 ) then
MsgBox Prog2 & vbCRLF & " existiert nicht. Das ist das Ende."
WScript.Quit
End If
Prog = "---"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Text" für die erste Frage zusammenbauen
Text = "Zur Zeit läuft keines der beiden Programme. " & vbCRLF
Text = Text & "Welches soll gestartet werden?" & vbCRLF & vbCRLF
Text = Text & "[ja]" & vbTab & Prog1 & vbCRLF & vbCRLF
Text = Text & "[nein]" & vbTab & Prog2 & vbCRLF
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' erste Frage stellen; Ergebnis steht dann in "Text"
Text = MsgBox( Text, vbYesNoCancel + vbQuestion , WScript.ScriptName)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn "Abbrechen" betätigt wurde
If Text = vbCancel then WScript.Quit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ausgewähltes Programm an Variable "Prog" übergeben
If Text = vbYes then Prog = Prog1
If Text = vbNo then Prog = Prog2
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ausgewähltes Programm starten
Set ProgExec = createObject("WScript.Shell").exec( Prog )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Do .. Loop"-Schleife immer wieder durchlaufen
Do
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 500ms Pause
WScript.Sleep 500
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' In der folgenden Abfrage-"MsgBox" soll je nach bereits
' laufenden Programm ein anderes Icon angezeigt werden
if Prog = Prog1 then MsgIcon = vbExclamation ' Warnung
if Prog = Prog2 then MsgIcon = vbInformation ' Information
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Text" für die folgende Abfrage-"MsgBox" zusammen bauen
Text = "Zuletzt wurde " & vbCRLF & vbCRLF
Text = Text & vbTab & Prog & vbCRLF & vbCRLF
Text = Text & "gestartet - soll jetzt " & vbCRLF & vbCRLF
if Prog = Prog1 then Text = Text & vbTab & Prog2 & vbCRLF & vbCRLF
if Prog = Prog2 then Text = Text & vbTab & Prog1 & vbCRLF & vbCRLF
Text = Text & "gestartet werden? "
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Abfrage-"MsgBox" stellen
Text = MsgBox( Text, vbOKCancel + MsgIcon , fso.GetFileName( Prog ) & " . . . wurde zuletzt gestartet." )
'----------------------------------------------------------------------------------
' Info zu vbOKCancel + MsgIcon
' der zweite Parameter (nach dem ersten Komma) legt fest, welche Schaltflächen
' und welches Bildchen zu sehen ist
'----------------------------------------------------------------------------------
' Info zu fso.GetFileName( Prog ) & " . . . wurde zuletzt gestartet."
' der dritte Parameter (nach dem zweiten Komma) legt den Tietel fest, der im
' oberen (blauen) Fensterbalken und damit unten in der Task-Leiste angezeigt
' wird.
'----------------------------------------------------------------------------------
' Info zu fso.GetFileName( Prog )
' löst den Dateinamen aus dem Dateinamen mit Pfadangabe heraus
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn "Abbrechen" betätigt wurde, "Do .. Loop"-Schleife
' verlassen
If Text = vbCancel then Exit Do
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn "Ok" betätigt wurde
If Text = vbOk then
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Das bereits laufende Programm beenden
ProgExec.terminate
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Text" erhält den "anderen" Programmnamen
if Prog = Prog1 then Text = Prog2
if Prog = Prog2 then Text = Prog1
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "anderes" Programm starten
Set ProgExec = createObject("WScript.Shell").exec( Text )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Prog" merkt sich, welches Programm gerade gestartet wurde
Prog = Text
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' . . . und es geht dort weiter, wo "Do" steht
Loop
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Das laufende Programm beenden
ProgExec.terminate
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Das Skript beenden bzw. verlassen
WScript.Quit
#########################################################################
>>> programmschliessen.vbs <<<
set WshShell = WScript.CreateObject("WScript.Shell")
progr = "Outlook Express"
WshShell.AppActivate progr
WshShell.sendkeys "%{F4}"
#########################################################################
>>> regkey.vbs <<<
' regkey.vbs
' http://msdn.microsoft.com/archive/en-us/dnarwsh/html/wsh_object.asp
'
' Windows Script Host Sample Script
'
' ---------------------------------------------------------------------
' Copyright (C) 1996-1997 Microsoft Corporation
'
' You have a royalty-free right to use, modify, reproduce and distribute
' the Sample Application Files (and/or any modified version) in any way
' you find useful, provided that you agree that Microsoft has no warranty,
' obligations or liability for any Sample Application Files.
' ---------------------------------------------------------------------
'
' This sample demonstrates how to write/delete entries in the registry.
L_Welcome_MsgBox_Message_Text = "This script demonstrates how to create and delete registry keys."
L_Welcome_MsgBox_Title_Text = "Windows Script Host Sample"
Call Welcome()
' **********************************************************************
' *
' * Registry related methods.
' *
Dim WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
WSHShell.Popup "Create key HKCU\MyRegKey with value 'Top level key'"
WSHShell.RegWrite "HKCU\MyRegKey\", "Top level key"
WSHShell.Popup "Create key HKCU\MyRegKey\Entry with value 'Second level key'"
WSHShell.RegWrite "HKCU\MyRegKey\Entry\", "Second level key"
WSHShell.Popup "Set value HKCU\MyRegKey\Value to REG_SZ 1"
WSHShell.RegWrite "HKCU\MyRegKey\Value", 1
WSHShell.Popup "Set value HKCU\MyRegKey\Entry to REG_DWORD 2"
WSHShell.RegWrite "HKCU\MyRegKey\Entry", 2, "REG_DWORD"
WSHShell.Popup "Set value HKCU\MyRegKey\Entry\Value1 to REG_BINARY 3"
WSHShell.RegWrite "HKCU\MyRegKey\Entry\Value1", 3, "REG_BINARY"
WSHShell.Popup "Delete value HKCU\MyRegKey\Entry\Value1"
WSHShell.RegDelete "HKCU\MyRegKey\Entry\Value1"
WSHShell.Popup "Delete key HKCU\MyRegKey\Entry"
WSHShell.RegDelete "HKCU\MyRegKey\Entry\"
WSHShell.Popup "Delete key HKCU\MyRegKey"
WSHShell.RegDelete "HKCU\MyRegKey\"
' ***********************************************************************
' *
' * Welcome
' *
Sub Welcome()
Dim intDoIt
intDoIt = MsgBox(L_Welcome_MsgBox_Message_Text, _
vbOKCancel + vbInformation, _
L_Welcome_MsgBox_Title_Text )
If intDoIt = vbCancel Then
WScript.Quit
End If
End Sub
#########################################################################
>>> shell32dllversion.vbs <<<
'v3.B**********************************************************
' File: SHELL32DLLversion.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Siehe WinFAQ.de - nach 'Active Desktop' suchen.
'**************************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME ); siehe Zeilenende ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
Text = "\system32"
If not "Windows_NT" = WScript.CreateObject("WScript.Shell").Environment("Process")("OS") then Text = "\system"
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
MsgBox UCASE( Text) & vbCRLF & "hat die Version: " & fso.GetFileVersion( text ), , WScript.ScriptName
#########################################################################
>>> sort-bubblesort.vbs <<<
'v3.6*****************************************************
' File: Sort-BubbleSort.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sortiert die Zeilen einer Datei alphabetisch
'
' Das Sortieren auf einem Pentium 600MHz von
' 10.000 Zeilen VBScript-Code dauert ca. 8 min
' mit 20..30% CPU-Last
'***************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then Datei = oArgs.item(i)
Next
' Gibt's keinen Dateinamen, werden halt die Zeilen des Skripts
' alphabetisch sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve arrTest(i)
arrTest(i) = FileIn.Readline
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
Text = UBound(arrTest) & " Zeilen der Datei " & Datei & " werden jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert." & vbCRLF
arrSort = bubblesort(arrTest) ' function - Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = Text & UBound(arrTest) & " Zeilen der Datei " & Datei & " sind jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert."
' Zieldatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & ".txt"
' Datei mit sortierten Zeilen füllen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Lesen öffnen
' FileOut.WriteLine( Text & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound(arrTest)
FileOut.WriteLine( i+1 & vbTab & arrTest(i) )
next
' FileOut.WriteLine( vbCRLF & vbCRLF & now() ) ' nur Für Testzwecke
FileOut.Close
Set FileOut = nothing
' Datei mit sortierten Zeilen anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run Datei
WScript.Sleep 3000
' Datei mit sortierten Zeilen löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile ( Datei )
WScript.Quit
'***************************************************************
function bubblesort(arrSortieren) ' funtion Anfang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim i, j
for i = 0 to ubound(arrSortieren)
for j = i + 1 to ubound(arrSortieren)
if UCase( arrSortieren(i) ) > UCase( arrSortieren(j) ) then
' Groß- und Kleinbuchstaben werden gelich behandelt
' -------------------------------------------------
' if arrSortieren(i) > arrSortieren(j) then
' erst alle Zeilen die mit Großbuchstaben beginnen
' dann alle Zeilen die mit Kleinbuchstaben beginnen
' -------------------------------------------------
bubblesort = arrSortieren(i)
arrSortieren(i) = arrSortieren(j)
arrSortieren(j) = bubblesort
end if
next
next
end function
#########################################################################
>>> sort-heapsort.vbs <<<
'v3.6*****************************************************
' File: Sort-HeapSort.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sortiert die Zeilen einer Datei alphabetisch
'
' Das Sortieren auf einem Pentium 600MHz von
' 10.000 Zeilen VBScript-Code dauert ca. 2:30 min
' mit 100% CPU-Last
'***************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then Datei = oArgs.item(i)
Next
' Gibt's keinen Dateinamen, werden halt die Zeilen des Skripts
' alphabetisch sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
Text = Text & now() & vbCRLF
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve arrTest(i)
arrTest(i) = FileIn.Readline
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
Text = UBound(arrTest) & " Zeilen der Datei " & Datei & " werden jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert." & vbCRLF
arrSort = HeapSort ( arrTest )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrSort = QuickSort(arrTest, LBound(arrTest), UBound(arrTest))
Text = Text & UBound(arrTest) & " Zeilen der Datei " & Datei & " sind jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert."
' Zieldatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & ".txt"
' Datei mit sortierten Zeilen füllen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Lesen öffnen
' FileOut.WriteLine( Text & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound(arrTest)
FileOut.WriteLine( i+1 & vbTab & arrTest(i) )
next
' FileOut.WriteLine( vbCRLF & vbCRLF & now() ) ' nur Für Testzwecke
Text = Text & now()
FileOut.Close
Set FileOuT = nothing
' Datei mit sortierten Zeilen anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run Datei
WScript.Sleep 3000
' Datei mit sortierten Zeilen löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile ( Datei )
WScript.Quit
'***************************************************************
' function QuickSort(vntArray, intVon, intBis) ' funtion Anfang
Function HeapSort(ByRef A) ' funtion Anfang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Aus der MS-NG am 13.03.2003 von von Hubert Daubmeier
Dim HeapSize, i
HeapSize = UBound(A) + 1
BuildHeap A, HeapSize
For i = UBound(A) To 1 Step -1
Swap A(0), A(i)
HeapSize = HeapSize - 1
Heapify A, 0, HeapSize
Next
End Function ' HeapSort(ByRef A)
Sub BuildHeap(ByRef A, ByVal HeapSize)
Dim i
For i = Int(HeapSize / 2) To 0 Step -1
Heapify A, i, HeapSize
Next
End Sub
Sub Heapify(ByRef A, ByVal i, ByVal HeapSize)
Dim l, r, Largest
l = 2 * i + 1
r = 2 * i + 2
Largest = i
If l < HeapSize Then
' If UCase( A(l) ) > UCase( A(i) ) Then Largest = l
If A(l) > A(i) Then Largest = l
End If
If r < HeapSize Then
If A(r) > A(Largest) Then Largest = r
' If UCase( A(r) ) > UCase( A(Largest) ) Then Largest = r
End If
If Largest <> i Then
Swap A(i), A(Largest)
Heapify A, Largest, HeapSize
End If
End Sub
Sub Swap(ByRef L, ByRef R)
Dim Temp
Temp = R
R = L
L = Temp
End Sub
#########################################################################
>>> sort-quicksort.vbs <<<
'v3.6*****************************************************
' File: Sort-QuickSort.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sortiert die Zeilen einer Datei alphabetisch
'
' Das Sortieren auf einem Pentium 600MHz von
' 10.000 Zeilen VBScript-Code dauert ca. 2:30 min
' mit 100% CPU-Last
'***************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then Datei = oArgs.item(i)
Next
' Gibt's keinen Dateinamen, werden halt die Zeilen des Skripts
' alphabetisch sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
Text = Text & now() & vbCRLF
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve arrTest(i)
arrTest(i) = FileIn.Readline
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
Text = UBound(arrTest) & " Zeilen der Datei " & Datei & " werden jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert." & vbCRLF
arrSort = QuickSort(arrTest, LBound(arrTest), UBound(arrTest))
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = Text & UBound(arrTest) & " Zeilen der Datei " & Datei & " sind jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert."
' Zieldatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & ".txt"
' Datei mit sortierten Zeilen füllen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Lesen öffnen
' FileOut.WriteLine( Text & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound(arrTest)
FileOut.WriteLine( i+1 & vbTab & arrTest(i) )
next
' FileOut.WriteLine( vbCRLF & vbCRLF & now() ) ' nur Für Testzwecke
Text = Text & now()
FileOut.Close
Set FileOut = nothing
' Datei mit sortierten Zeilen anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run Datei
WScript.Sleep 3000
' Datei mit sortierten Zeilen löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile ( Datei )
WScript.Quit
'***************************************************************
function QuickSort(vntArray, intVon, intBis) ' funtion Anfang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't
' Private Sub QuickSort(vntArray, intVon, intBis)
Dim i, j
Dim vntTestWert, intMitte, vntTemp
If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis
Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop
Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop
If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If
end function
#########################################################################
>>> stringanpositionindateitauschen.vbs <<<
'v3.1***********************************************************
' File: StringAnPositionInDateiTauschen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Ersetzt in jeder Zeile einer Datei Zeichen an einer Position.
'***************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim Aktion, Akt1, Akt2, SendToLink
Dim TxtParameter, TxtErsatz, TxtSonderz, TextNeu
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set oArgs = Wscript.Arguments
SendToLink = fso.GetBaseName( WScript.ScriptName )
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
TxtParameter = "Folgende Parameter sind möglich:" & vbCRLF
TxtParameter = TxtParameter & " l 10 " & vbTab & "ersetzt in jeder Zeile die " & vbCRLF
TxtParameter = TxtParameter & vbTab & vbTab & "ersten (linken) 10 Zeichen" & vbCRLF
TxtParameter = TxtParameter & " r 10 " & vbTab & "ersetzt in jeder Zeile die " & vbCRLF
TxtParameter = TxtParameter & vbTab & vbTab & "letzten (rechten) 10 Zeichen" & vbCRLF
TxtParameter = TxtParameter & " m 10 20 " & vbTab & "ersetzt in den Zeilen (mittendrin) " & vbCRLF
TxtParameter = TxtParameter & vbTab & vbTab & "die Zeichen an Pos. 10 bis 20 " & vbCRLF & vbCRLF
TxtErsatz = "Als ERSATZ sind beliebige Zeichen möglich:" & vbCRLF
TxtErsatz = TxtErsatz & "- wird kein Zeichen eingegeben, werden die " & vbCRLF
TxtErsatz = TxtErsatz & " (z.B. 10) Zeichen gelöscht." & vbCRLF
TxtErsatz = TxtErsatz & "- 3 Leerzeichen ("" "") ersetzen (z.B.10) Zeichen." & vbCRLF & vbCRLF
TxtSonderz = "Folgende Sonderzeichen sind nur einzeln als ERSATZ einsetzbar: " & vbCRLF
TxtSonderz = TxtSonderz & " vbCRLF" & vbTab & "neue Zeile (bzw. vbLF / vbCR)" & vbCRLF
TxtSonderz = TxtSonderz & " vbTab " & vbTab & "Tabulator" & vbCRLF
TxtSonderz = TxtSonderz & " vbNullChar" & vbTab & "ein NULL-Zeichen Chr(0)," & vbCRLF
TxtSonderz = TxtSonderz & vbTab & vbTab & "also kein! Leerschritt" & vbCRLF
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
If oArgs.Count = 2 then SkriptInfo ' SUB Aufruf
If oArgs.Count > 4 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Aktion = "---"
Akt1 = 0
Akt2 = 0
If oArgs.Count = 1 then
Datei = oArgs.item(1-1) ' #X#~-_-~#X#
if not fso.FileExists( Datei ) then
Text = "Die Datei " & Datei & " existiert nicht!"
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende." , 64
WScript.Quit
End If
Else
Akt1 = oArgs.item(3-1) ' #X#~-_-~#X#
Aktion = oArgs.item(2-1) ' #X#~-_-~#X#
Datei = oArgs.item(1-1) ' #X#~-_-~#X#
Aktion = UCase( Aktion )
End If
Akt1 = CInt( Akt1 )
If oArgs.Count = 4 then ' vier Param.? - das muss Datei und "m 10 20" sein
Akt2 = oArgs.item(4-1) ' #X#~-_-~#X#
Akt2 = CInt( Akt2 )
if Aktion = "M" AND Akt2 >= Akt1 AND Akt1 > 0 then Mittendrin ' Sub Aufruf
' ~~~ ~~~ ~~~
End If
if Aktion = "L" then Links ' Sub Aufruf
if Aktion = "R" then Rechts ' Sub Aufruf
' wurde nur eine Datei (Drag & Drop) übergeben, müssen die parameter erfragt werden
Text = UCase ( Datei) & " soll bearbeitet werden. " & vbCRLF & vbCRLF
Text = Text & TxtParameter & TxtErsatz & TxtSonderz
Text = InputBox( Text, WScript.ScriptName)
' ~~~~~~~~
Txt = UCase( Left( Text, 2)) ' die linken zwei Zeichen
if Txt = "L " then Aktion = UCase( Left( Txt, 1))
if Txt = "R " then Aktion = UCase( Left( Txt, 1))
if Txt = "M " then Aktion = UCase( Left( Txt, 1))
Text = UCase( Mid( Text, 3)) ' die Zeichen nach den ersten beiden
if 0 = InStr (Text, " " ) then Akt1 = Cint(Text) ' es gibt nur einen Parameter
if not 0 = InStr (Text, " " ) then ' es gibt mehrer Parameter
if Len( Text) > InStr( Text, " " ) then
Akt1 = Left( Text, InStr (Text, " " ) -1)
Akt1 = CInt( Akt1 )
Text = UCase( Mid( Text, InStr (Text, " " ) +1)) ' den nächsten Parameter
if 0 = InStr (Text, " " ) then Akt2 = Text ' es gibt nur einen weiteren Parameter
if not 0 = InStr (Text, " " ) then ' es gibt mehrer weiteren Parameter
Akt2 = Left( Text, InStr (Text, " " ) -1)
Akt2 = CInt( Akt2 )
End If
End If
End If
' MsgBox Aktion & vbCRLF & Akt1 & vbCRLF & Akt2 & vbCRLF & Datei, , "Aktion Akt1 Akt2 Datei"
if Aktion = "L" then Links ' Sub Aufruf
if Aktion = "R" then Rechts ' Sub Aufruf
if Aktion = "M" then
if akt1 < akt2 then Mittendrin ' Sub Aufruf
End If
Text = "Das waren: Keine VERNÜNFTIGEN Eingaben!" & vbCRLF & vbCRLF
Text = Text & Aktion & " " & akt1 & " " & akt2
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende." , 64
WScript.Quit
'***************************************************************
' ENDE - Das eigentliche Skript beginnt (SUB'S weiter unten)
'***************************************************************
Sub SendenAnLink ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End Sub ' SendenAnLink
Sub SkriptInfo ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
Text = Text & "Das Ganze funktioniert so:" & vbCRLF
Text = Text & " Eine Datei mit der Mouse auf das Skript ziehen " & vbCRLF
Text = Text & " und fallen lassen ODER dem Skript über " & vbCRLF
Text = Text & " 'Senden an' die Datei übergeben. " & vbCRLF & vbCRLF
Text = Text & TxtParameter & TxtErsatz & TxtSonderz
MsgBox Text, , "WScript.Quit"
WScript.Quit
End Sub ' SkriptInfo
Sub Links ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "Links >" & Aktion & "< >" & Akt1 & "< >" & Akt2 & "<", , "WScript.Quit"
Text = "In der Datei " & UCase(Datei) & " sollen die linken (ersten) Zeichen bis zum Zeichen "
Text = Text & Akt1 & " ersetzt werden. " & vbCRLF & vbCRLF
Text = Text & TxtErsatz & TxtSonderz & vbCRLF
Text = Text & "Wie lauten die Ersatz-Zeichen?"
TextNeu = Ersatz ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
Datei = Datei & ".txt"
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Schreiben öffnen
FileOut.Writeline ( WScript.ScriptName & " " & Aktion &" " & Akt1 ) ' eine Zeile schreiben
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zuende ist, weiter machen
i = i + 1
Text = FileIn.Readline ' eine Zeile lesen
if Len( Text ) >= CInt(Akt1) then
Text = TextNeu & Mid ( Text , CInt(Akt1) +1 )
Else
Text = TextNeu
End If
FileOut.Writeline (Text) ' eine Zeile schreiben
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.Run Datei
WScript.Quit
End Sub ' Links
Sub Rechts ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "Rechts >" & Aktion & "< >" & Akt1 & "< >" & Akt2 & "<", , "WScript.Quit"
Text = "In der Datei " & UCase(Datei) & " sollen alle! Zeichen ab dem Zeichen "
Text = Text & Akt1 & " (inkl. Zeichen " & Akt1 & ") ersetzt werden. " & vbCRLF & vbCRLF
Text = Text & TxtErsatz & TxtSonderz & vbCRLF
Text = Text & "Wie lauten die Ersatz-Zeichen?"
TextNeu = Ersatz ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
Datei = Datei & ".txt"
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Schreiben öffnen
FileOut.Writeline ( WScript.ScriptName & " " & Aktion &" " & Akt1 ) ' eine Zeile schreiben
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zuende ist, weiter machen
i = i + 1
Text = FileIn.Readline ' eine Zeile lesen
if Len( Text ) >= CInt(Akt1) then
Text = Mid ( Text , 1, CInt(Akt1) -1 ) & TextNeu
' Else
' Text = ""
End If
FileOut.Writeline (Text) ' eine Zeile schreiben
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.Run Datei
WScript.Quit
End Sub ' Rechts
Sub Mittendrin ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "MittenDrin >" & Aktion & "< >" & Akt1 & "< >" & Akt2 & "<", , "WScript.Quit"
Text = "In der Datei " & UCase(Datei) & " sollen die Zeichen von "
Text = Text & Akt1 & " bis " & Akt2 & " ersetzt werden. " & vbCRLF & vbCRLF
Text = Text & TxtErsatz & TxtSonderz & vbCRLF
Text = Text & "Wie lauten die Ersatz-Zeichen?"
TextNeu = Ersatz ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1, true) ' Datei zum Lesen öffnen
Datei = Datei & ".txt"
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Schreiben öffnen
FileOut.Writeline ( WScript.ScriptName & " " & Aktion &" " & Akt1 & " " & Akt2 ) ' eine Zeile schreiben
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zuende ist, weiter machen
i = i + 1
Text = FileIn.Readline ' eine Zeile lesen
if Len( Text ) >= CInt(Akt2) then
Text = Mid ( Text , 1, CInt(Akt1) -1 ) & TextNeu & Mid ( Text , CInt(Akt2) +1 )
Else
if Len( Text ) >= CInt(Akt1) then
Text = Mid ( Text , 1, CInt(Akt1) -1 ) & TextNeu
End If
End If
FileOut.Writeline (Text) ' eine Zeile schreiben
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.Run Datei
WScript.Quit
End Sub ' Mittendrin
Function Ersatz ' Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ersatz = InputBox( Text, WScript.ScriptName)
if UCase(Ersatz) = UCase("vbCRLF" ) then Ersatz = Chr(13) & Chr(10)
if UCase(Ersatz) = UCase("vbCR" ) then Ersatz = Chr(13)
if UCase(Ersatz) = UCase("vbLF" ) then Ersatz = Chr(10)
if UCase(Ersatz) = UCase("vbTab" ) then Ersatz = Chr(9)
if UCase(Ersatz) = UCase("vbNullChar" ) then Ersatz = Chr(0)
End Function ' Ersatz
#########################################################################
>>> stringindatei.vbs <<<
'v3.6*****************************************************
' File: StringInDatei.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Script sucht in einer Datei nach einer Zeichenkette und
' speichert jede Zeile, die diese Zeichenkette enthält, mit
' Zeilennummer in eine andere Datei.
'*********************************************************
Option Explicit
Dim WSHShell, FSO, FileIn, FileOut
Dim EingDatei, Ausgdatei, ZKette, Zeile, Antwort, i
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
EingDatei = "error.log"
AusgDatei = "fehler.log"
ZKette = "msgbox"
ZKette = InputBox ("Nach welcher Zeichenkette soll in einer Datei gesucht werden?", WScript.ScriptName, ZKette)
If ZKette = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, WScript.ScriptName, 64
WScript.Quit
End If
EingDatei = InputBox ("Welche Datei soll nach '" & ZKette & "' durchsucht werden?", WScript.ScriptName, EingDatei)
If EingDatei = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, WScript.ScriptName, 64
WScript.Quit
End If
if not fso.FileExists(EingDatei) Then
WSHShell.Popup (EingDatei & "existiert nicht. Zur Demo wird dieses Skript " & WScript.ScriptName & " nach " & EingDatei & " kopiert."), 3, WScript.ScriptName, 64
FSO.CopyFile WScript.ScriptName, EingDatei ' fals Datei nicht vorhanden, dieses Script nach error.log kopieren - zum Testen
End If
if not fso.FileExists(EingDatei) Then ' fals Datei nicht vorhanden
MsgBox "Datei " & EingDatei & " zum Einlesen fehlt.", , WScript.ScriptName
WScript.Quit
End If
AusgDatei = InputBox ("In welche Datei sollen die Zeilen mit der Zeichenkette" & vbCRLF & "'" & ZKette & "'" & vbCRLF & "gespeichert werden?", WScript.ScriptName, AusgDatei)
If AusgDatei = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, WScript.ScriptName, 64
WScript.Quit
End If
if fso.FileExists(AusgDatei) Then
Antwort = MsgBox (AusgDatei & " existiert bereits - soll sie gelöscht werden?", 4+32+256, WScript.ScriptName)
If Antwort = vbYes then fso.DeleteFile(AusgDatei), True
End If
Set FileIn = FSO.OpenTextFile(EingDatei, 1, true) ' Datei zum Lesen öffnen
Set FileOut = fso.OpenTextFile(AusgDatei, 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
fileOut.WriteLine( vbCRLF & now() & vbTab & "Zeichenkette '" & ZKette & "' gefunden in Zeile(n):")
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = i + 1
Zeile = FileIn.Readline ' eine Zeile lesen
If InStrRev( UCase( Zeile), UCase( ZKette)) > 0 Then fileOut.WriteLine(i & vbTab & ":" & Zeile)
' InStrRev(..) sucht von hinten, ob Zeichenfolge vorhanden
' ist und gibt die Position des ersten Auftretens zurück -
' wenn die Positon größer als 1, wird die Zeile in die
' Ausgabedatei geschrieben
' If InStr(TextU, ZKette) > 0 Then fileOut.WriteLine(i & vbTab & TextU)
' InStr(..) sucht von vorn, . . .
Loop
FileIn.Close
Set FileIn = Nothing ' Datei schließen
FileOunt.Close
Set FileOut = Nothing ' Datei schließen
WSHShell.Run AusgDatei
' WSHShell.Run "Notepad.exe " & AusgDatei
#########################################################################
>>> stringindateitauschen.vbs <<<
'v2.7********************************************************
' File: StringInDateiTauschen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' In den Zeilen dürfen keine Anführungszeichen " stehen!
'
' dateiliste.txt stellt eine Liste der zu prüfenden Dateien
' bereit. Beim Skriptaufruf wird nach der zu suchenden
' Zeichenkette gefragt. Diese wird bei der Abfrage, wie die
' Zeichenkette zukünftig aussehen soll angezeigt und
' kann geändert werden.
'************************************************************
Option Explicit
Dim fso, fo, fi, FinList, Fin, Fout
Dim Ziel, Quelle, WSHShell, ZielVerz
Dim TextX, Text1, Text2, Text3, Txt(), i, i1
Dim aHTML, eHTML, StringAlt, StringNeu, iText, DateiListe
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
ZielVerz = "m:\dieseyer.test"
ZielVerz = fso.GetParentFolderName( WScript.ScriptFullName )
DateiListe = ZielVerz & "\dateiliste.txt"
If not fso.FileExists( DateiListe ) Then MsgBox DateiListe & " existiert nicht!", , WSCript.ScriptName
If not fso.FileExists( DateiListe ) Then WScript.Quit
'---------------------------------------------------------
' DateiListe zeilenweise lesen (für Anzeige)
'---------------------------------------------------------
iText = ""
Set FinList = FSO.OpenTextFile( DateiListe, 1, true) ' Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
Text1 = Text1 & vbCRLF & " " & TextX
End If
Loop
FinList.Close
Set FinList = nothing
TextX = ""
TextX = TextX & "In folgenden Dateien werden Zeichenketten ausgetauscht:" & vbCRLF
TextX = TextX & Text1
i = MsgBox (TextX, 4 + 32 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text1 = Text1 & "Wie lautet die Zeichenfolge (StringAlt), die erstezt werden soll?"
StringAlt = InputBox ( Text1 , WSCript.ScriptName , StringAlt)
If StringAlt = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
Text1 = ""
Text1 = Text1 & "Folgende Zeichenfolge (StringAlt) soll in den soeben gezeigten Dateien ausgetauscht werden."
Text1 = Text1 & "Ändern Sie jetzt diese Zeichenkette, um festzulegen, wie die Zeichenkette in Zukunft (StringNeu) aussehen soll."
StringNeu = InputBox ( Text1 , WSCript.ScriptName , StringAlt)
If StringNeu = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
If StringAlt = StringNeu then
WSHShell.PopUp "Wenn StringNeu" & vbCRLF & " " & StringNeu & vbCRLF & "und StringAlt" & vbCRLF & " " & StringAlt & vbCRLF & "gleich sind, wird's nichts!", , WScript.Scriptname
WSCript.Quit
End If
TextX = "DAS IST DIE LETZTE WARNUNG!" & vbCRLF & vbCRLF & TextX
i = MsgBox (TextX, 4 + 48 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text2 = ""
'---------------------------------------------------------
' DateiListe zeilenweise lesen & Zeichenkette(n) tauschen
'---------------------------------------------------------
Set FinList = FSO.OpenTextFile( DateiListe, 1, true) ' DateiListe-Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn DateiListe-Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
If not Text2 = "" then
Text1 = Text1 & vbCRLF & TextX & vbTab & " übersprungen"
Else
' MsgBox textx
Text3 = StringInDateiTauschen( TextX, StringAlt, StringNeu) ' Function Aufruf
if vbcancel = WSHShell.Popup (TextX & " . . . wurde bearbeitet.", 1, WScript.ScriptName, 1 + 64 ) Then Text2 = "übergehen"
Text1 = Text1 & vbCRLF & TextX & Text3
' Text1 = Text1 & vbCRLF & TextX & i
End If
End If
Loop
FinList.Close
Set FinList = nothing
MsgBox Text1, , WScript.ScriptName
WScript.Quit
Function StringInDateiTauschen (Datei, Suchen, Ersetzen)
Dim FileContents, dFileContents
if not WScript.CreateObject("Scripting.FileSystemObject").FileExists(Datei) then WScript.CreateObject("WScript.Shell").PopUp "Datei nicht gefunden!", 15, WScript.Scriptname
if not WScript.CreateObject("Scripting.FileSystemObject").FileExists(Datei) then Exit Function
FileContents = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(Datei).ReadAll ' Datei einlesen
dFileContents = Replace(FileContents, Suchen, Ersetzen, 1, -1, 1) ' Ersetze alle Strings im Quellfile
If dFileContents <> FileContents Then ' Vergleiche Quelle und Ergebnis
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(Datei, 2, True).Write dFileContents ' Schreibe Ergebnis wenn Unterschied besteht
' WScript.CreateObject("WScript.Shell").PopUp "Austausch in Datei """ & Datei & """ abgeschlossen " , 1, WSCript.ScriptName, vbExclamation
Else
' WScript.CreateObject("WScript.Shell").PopUp "Der angegebene String ==|" & Suchen & "|== konnte nicht in der Datei """ & Datei & """ gefunden werden." , 5, WSCript.ScriptName, vbExclamation
End If
End Function ' StringInDateiTauschen
#########################################################################
>>> timeset.vbs <<<
' (C) 2001 by Dr. Tobias Weltner, www.scriptinternals.de
' atomuhr.vbs
' http://www.scriptinternals.de/content/4-Anwendungen/uhrzeit/atomuhr/atomuhr0.htm
' atomuhr.vbs
'
'v2.3*****************************************************
' File: timeset.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
' Erweitert und verändert durch Service.CD@gmx.de zu timeset.vbs
' Dadurch ist es möglich die Zeit per Scheduler zu setzen:
' - PopUp... (anstatt MsgBox) - Meldungen verschwinden von selbst
' - Nur wenn die Abweichung kleiner +/- 600 Sekunden wird die Zeit autom. gesetzt.
' - Es wird eine Protokolldatei timeset.log
'
'*********************************************************
' #X# DIESER TEIL AUTOMATISCH EINGESETZT, UM DAS STARTEN DES SCRIPTS ÜBER DAS INTERNET ZU VERHINDERN:
if Instr(wscript.ScriptFullName, "Temporary Internet File")>0 then if MsgBox("Öffnen Sie NIEMALS direkt ein Skript im Internet - es könnte Viren enthalten! Trotzdem öffnen und sofort ausführen?",vbYesNo+vbQuestion,"Sicherheitshinweis")=vbNo then MsgBox "Gute Entscheidung! Wiederholen Sie das Download, und speichern Sie das Skript diesmal zuerst!",vbInformation : wscript.quit
' #X# ENDE AUTOMATISCHER TEIL
Dim remotedate, diff, newnow, datumjetzt, tagabweichung, zeitjetzt, sekabweichung
Dim TextX, FileOut, MaxKorrektur
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' Set wshshell = CreateObject("WScript.Shell")
Set http = GetHTTPObject
MaxKorrekt = 600 ' max. Abweichung, bei der die Zeit autom. gesetzt wird
' ist die Abweichung größer, muss die Zeit von Hand gesetzt werden
Zeitzone = wshshell.RegRead("HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
If IsArray(Zeitzone) Then
HexVal = Hex(Zeitzone(3)) & Hex(Zeitzone(2)) & Hex(Zeitzone(1)) & Hex(Zeitzone(0))
Else
HexVal = Hex(Zeitzone)
End If
Zeitzone = - CLng("&H" & HexVal) / 60
' wshshell.Popup "Zeitunterschied zu GMC: " & Zeitzone & " Stunde" , 2
' MsgBox "Zeitunterschied zu GMC: " & Zeitzone & "h"
ZeitAnfrage
TextX= ""
TextX= TextX & "remotedate: " & vbTab & remotedate & vbCRLF
TextX= TextX & "diff : " & vbTab & vbTab & diff & vbCRLF
TextX= TextX & "newnow : " & vbTab & newnow & vbCRLF
TextX= TextX & "datumjetzt : " & vbTab & datumjetzt & vbCRLF
TextX= TextX & "tagabweichung : " & vbTab & tagabweichung & vbCRLF
TextX= TextX & "zeitjetzt : " & vbTab & vbTab & zeitjetzt & vbCRLF
TextX= TextX & "sekabweichung : " & vbTab & sekabweichung & vbCRLF
' wshshell.Popup TextX, 5, WScript.ScriptName
If sekabweichung < 2 and sekabweichung > -2 Then
wshshell.Popup "Systemzeit ok!" & vbCRLF & "Abweichung: " & sekabweichung & " Sek.", 5, WScript.ScriptName & " - keine Korrektur"
TextX = newnow & " " & sekabweichung & " " & vbTab & " Sekunden Abweichung - keine Korrektur erforderlich. "
LogDatei ' Sub LogDatei
Else
If sekabweichun
#########################################################################
>>> txtquerdruck.vbs <<<
'v3.B***********************************************************
' File: TXTQuerDruck.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' kopiert Datei(en) zum Drucker, die dann im Querformat gedruckt
' werden.
'
' ACHTUNG:
' Jedes Zeichen der Datei(en) kommt beim Drucker an. Man sollte
' also nur ASCII-Dateien (z.B. Quelltexte) verwenden, sonst werden
' !!! HUNDERTE !!! Seiten mit Schwachsinn bedruckt.
'***************************************************************
Option Explicit
Dim SendToLink, Text, TextX, i
Dim oArgs, WSHShell, fso
Dim Drucker, Datei, TmpDatei, FileOut
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
SendToLink = "Text quer drucken"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
'***************************************************************
' ANFANG des eigentlichen Skripts
'***************************************************************
Text = ""
' WSHShell.run UCase("net use lpt2 /DELETE") , 0, True
' WSHShell.run UCase("net use lpt2: \\PrintSrv\LJ4plus") , 0, True
TmpDatei = WScript.ScriptFullName & ".Tmp"
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then
Text = Left( UCase(oArgs.item(i)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
End If
If Drucker = "" then Drucker = Druckerauswahl ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & i & vbTab & oArgs.item(i) & vbTab & Drucker & vbCRLF ' Protokoll
Set FileOut = fso.OpenTextFile (TmpDatei, 2, true) ' TmpDatei neu anlegen (2)
' FileOut.WriteLine ( Chr(27) & "E" & Chr(27) & "&l1O" )
FileOut.WriteLine ( Chr(27) & "E" & Chr(27) & "&l1O" & Chr(27) & "(s16H" & Chr(27) & "&l12D" )
' | | | 12 Zeilen pro Zoll - 8, 12, 16 sind möglich
' | | 16 Zeichen pro Zoll - Schriftgröße
' | &l1O Querformat
' E DruckerReset - in Einschaltzustand zurück setzen
FileOut.WriteLine ("#-#-# => " & oArgs.item(i) & " - gedruckt am " & now() & " <= #-#-#" )
Set FileOut = nothing ' TmpDatei schließen
Text = "%comspec% /c copy /b """ & TmpDatei & """ +""" & oArgs.item(i) & """ """ & TmpDatei & """ "
' Zusammensetzen der TmpDatei: TmpDatei und zu druckende Datei
' WSHShell.Popup Text, 10, WScript.ScriptName , 64
WSHShell.run Text , 0, True
Set FileOut = fso.OpenTextFile (TmpDatei, 8, true) ' TmpDatei erweitern (8)
' FileOut.WriteLine (Text)
FileOut.WriteLine (Chr(27) & "E") ' TmpDatei mit DruckerReset-Esc-Sequenz (SeitenVorschub) (PCL)
Set FileOut = nothing ' TmpDatei schließen
' WSHShell.Popup TmpDatei & vbTab & Drucker , 10, WScript.ScriptName , 64
FSO.CopyFile TmpDatei, Drucker ' Datei zum Drucker kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = Datei & vbCRLF
Next
' if fso.FileExists (TmpDatei) then MsgBox "fso.FileDelete (" & TmpDatei & ")"
if fso.FileExists (TmpDatei) then fso.DeleteFile (TmpDatei)
'***************************************************************
' ENDE des eigentlichen Skripts
'***************************************************************
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
'***************************************************************
Sub SkriptInfo ' Sub Aufruf
'***************************************************************
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Entweder ein oder mehrere Dateien bzw. Verzeichnisse " & vbCRLF
Text = Text & "mit der Mouse auf das Skript ziehen und fallen lassen, " & vbCRLF
Text = Text & "oder dem Skript über 'Senden an' die Dateien bzw. " & vbCRLF
Text = Text & "Verzeichnisse übergeben. " & vbCRLF & vbCRLF
Text = Text & "Wenn es sich nicht um TXT- oder PRN- Dateien handelt," & vbCRLF
Text = Text & "können es ! HUNDERTE ! Seiten werden!" & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & fso.GetBaseName( WScript.ScriptName ) & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
'***************************************************************
Function Druckerauswahl ' Anfanfg
'***************************************************************
' Es kann nur auf LPT? und Netzwerkdrucker kopiert werden
Dim i, n, Text, DruckerNr, NetPRN, WSHNet
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
n = 0
' welche Drucker sind verwendbar:
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
End If
Next
Text = Text & vbCRLF & "Auf welchen Drucker soll gedruckt werden?"
DruckerNr = InputBox (Text, WScript.ScriptName)
DruckerNr = Asc( DruckerNr ) -48
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
DruckerNr = Asc( DruckerNr ) -48
End If
If DruckerNr > n OR DruckerNr < 1 then DruckerNr = ""
If DruckerNr = "" then WSHShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
If DruckerNr = "" then WScript.Quit
n = 0
' gewählten Drucker ermitteln
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i+1)
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i )
End If
End If
Next
End Function ' Druckerauswahl
'***************************************************************
#########################################################################
>>> txtzulpt1.vbs <<<
'v2.4*****************************************************
' File: TXTzumLPT1.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Kopiert eine Datei direkt zum Drucker. Es wird jedes!!!
' Zeichen der Datei zum Drucker geschickt. Man sollte also
' nur .PRN- oder ASCII-Dateien (z.B. Quelltexte) verwenden.
'
' Es gibt Scanner, mit denen es möglich ist, den Scanner,
' zusammen mit am PC angeschlossenen Drucker, als Kopierer
' zu nutzen. Auf dem PC ist zum Standarddrucker ein wei-
' terer gleicher Drucker zu installieren, der in eine
' Datei druckt. Nutzt man jetzt die Kopierer-Funktion,
' entsteht eine Datei (mit der Endung .PRN).
'
' Ich habe das mal verwendet, um die zahlreichen Kopien
' für meine Bewerbungen mit einem Laserdrucker zu drucken.
'*********************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments ' hole Argumentsauflistung
If oArgs.Count > 0 Then ' gibt es Argumente?
Datei = oArgs.item(0) ' erstes Argument
Else
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Mouse ein Datei auf das Skript ziehen und" & vbCRLF
Text = Text & "fallen lassen - JETZT wird die Datei zum Drucker" & vbCRLF
Text = Text & "an LPT1 kopiert . . ." & vbCRLF & vbCRLF
Text = Text & "Wenn es keine TXT-Datei ist, können es HUNDERTE! " & vbCRLF
Text = Text & "Seiten werden!" & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
Drucker = "\\MeinPC\Drucker"
Drucker = "\\MeinPC\Drucker"
Drucker = "LPT1:"
Drucker = InputBox ("Auf welchen Drucker soll """ & Datei & """ gedruckt werden?", WScript.ScriptName, Drucker)
If Drucker = "" then WScript.Quit
' MsgBox "Copy " & Datei & " nach " & Drucker
FSO.CopyFile Datei, Drucker
TextX = Datei & " wurde zum Drucker " & Drucker & " kopiert!" & vbCRLF & vbCRLF
TextX = TextX & "Möglicherweise muss von Hand der Seitenvorschub ausgelöst werden!"
WSHShell.Popup TextX, 15, WScript.ScriptName
#########################################################################
>>> txtzumdrucker.vbs <<<
'v3.B***********************************************************
' File: TXTzumDrucker.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Kopiert eine Datei direkt zum Drucker. Es wird jedes!!!
' Zeichen der Datei zum Drucker geschickt. Man sollte also
' nur .PRN- oder ASCII-Dateien (z.B. Quelltexte) verwenden.
'
' Es gibt Scanner, mit denen es möglich ist, den Scanner,
' zusammen mit am PC angeschlossenen Drucker, als Kopierer
' zu nutzen. Auf dem PC ist zum Standarddrucker ein wei-
' terer gleicher Drucker zu installieren, der in eine
' Datei druckt. Nutzt man jetzt die Kopierer-Funktion,
' entsteht eine Datei (mit der Endung .PRN).
'
' Ich habe das mal verwendet, um die zahlreichen Kopien
' für meine Bewerbungen mit einem Laserdrucker zu drucken.
'
' 1b 45 = 27 69 = <Esc> E = PCL-DruckerReset / Seitenvorschub
' siehe Zeile 80: FSO.CopyFile TmpDatei, Drucker
'***************************************************************
Option Explicit
Dim WSHShell, FSO, WSHNet, NetPrn, oArgs
Dim FileOut, Text, Drucker, DruckerNr, Datei, TmpDatei, i
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
set oArgs = Wscript.Arguments ' Argumente bereit stellen
If not oArgs.Count > 0 Then ' gibt es Argumente?
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Mouse Datei(en) auf das Skript ziehen und" & vbCRLF
Text = Text & "fallen lassen . . . dann wird's was!" & vbCRLF & vbCRLF
Text = Text & "Wenn es sich nicht um TXT- oder PRN- Dateien handelt," & vbCRLF
Text = Text & "können es HUNDERTE ! Seiten werden!" & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
If Drucker = "" then Drucker = Druckerauswahl ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~
TmpDatei = WScript.ScriptFullName & ".Tmp"
Set FileOut = fso.OpenTextFile (TmpDatei, 2, true)
FileOut.WriteLine (Chr(27) & "E") ' Datei mit Seitenvorschub-Zeichenkette erstellen
FileOut.Close
Set FileOut = nothing
' if fso.FileExists (TmpDatei) then MsgBox WScript.ScriptName & ".Tmp"
Datei = ""
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = Datei & " " & oArgs.item(i) & vbCRLF ' Protokoll
FSO.CopyFile oArgs.item(i), Drucker ' Datei zum Drucker kopieren
if fso.FileExists (TmpDatei) then
' nächste Zeile nur wenn erforderlich freigeben
' FSO.CopyFile TmpDatei, Drucker ' Datei mit Seitenvorschub-Zeichenkette zum Drucker kopieren
End If
Next
' if fso.FileExists (TmpDatei) then MsgBox "fso.FileDelete (" & TmpDatei & ")"
if fso.FileExists (TmpDatei) then fso.DeleteFile (TmpDatei)
Text = Datei & "wurde(n) zum Drucker an " & Drucker & " kopiert!" & vbCRLF & vbCRLF
Text = Text & "Möglicherweise muss von Hand der Seitenvorschub ausgelöst werden!"
WSHShell.Popup Text, 15, WScript.ScriptName
'***************************************************************
Function Druckerauswahl ' Anfanfg
'***************************************************************
' Es kann nur auf LPT? und Netzwerkdrucker kopiert werden
Dim i, n, Text, DruckerNr, NetPRN, WSHNet
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
n = 0
' welche Drucker sind verwendbar:
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
End If
Next
Text = Text & vbCRLF & "Auf welchen Drucker soll gedruckt werden?"
DruckerNr = InputBox (Text, WScript.ScriptName)
DruckerNr = Asc( DruckerNr ) -48
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
DruckerNr = Asc( DruckerNr ) -48
End If
If DruckerNr > n OR DruckerNr < 1 then DruckerNr = ""
If DruckerNr = "" then WSHShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
If DruckerNr = "" then WScript.Quit
n = 0
' gewählten Drucker ermitteln
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i+1)
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i )
End If
End If
Next
End Function ' Druckerauswahl
'***************************************************************
#########################################################################
>>> userislogon-wmi.vbs <<<
'v3.A**********************************************************
' File: UserIsLogon-Wmi.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' gibt den gerade angemeldeten User zurück
'**************************************************************
Option Explicit
Dim Server
Server = ""
If Server = "" Then
MsgBox "Servername oder IP-Adresse angeben!" & vbCRLF & vbCRLF & ". . . das ist das Ende" , , WScript.ScriptName
WScript.Quit
End If
MsgBox WMIinfo ( Server ), , WScript.ScriptName
MsgBox WMIinfo ( "192.168.0.1" ), , WScript.ScriptName
WScript.Quit
'**************************************************************
'**************************************************************
Function WMIinfo ( Server ) ' Anfang
'**************************************************************
Dim objWMIService, colItems, objItem
On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\" & Server & "\root\cimv2")
if not err.Number = 0 then
If err.Number = -2147217405 Then err.Description = "Access Denied"
WMIinfo = Server & " ==>" & err.Description & " - Fehlernr. " & err.Number
WScript.Quit
End If
Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
For Each objItem in colItems
if not objItem.UserName = "" then
WMIinfo = Server & " ==> " & objItem.UserName & vbTab & " ist angemeldet"
Else
WMIinfo = Server & " ==> kein angemeldeter User"
End If
Next
On Error GoTo 0
End Function ' WMI ( Server )
'**************************************************************
#########################################################################
>>> verz-suchen-loeschen-test.vbs <<<
'v2.4***************************************************
' File: Verz-Suchen-Loeschen-Test.VBS Ergänzung zu
' Verz-Suchen-Loeschen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Verz_Suchen_Loeschen.VBS ist Ergebnis einer Newsgroup-
' Anfrage: Auf einem Server müssen die 'Temporary Inter-
' net Files' in allen ...\user\... Verzeichnissen kom-
' plett gelöscht werden.
' Um das nicht gleich hart in einer Produktionsumbegung
' testen zu müssen, habe ich noch
' Verz_Suchen_Loeschen-Test.VBS
' geschrieben, dass diese Verzeichnisstruktur zum Test
' mal eben auf C:\ erstellt
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
UserVerz = "C:\uSer\"
Dim User (50)
User(0) = "ing"
User(1) = "meister"
User(2) = "stift"
User(3) = "herr"
User(4) = "frau"
User(5) = "Miss"
User(6) = "Mister"
User(7) = "König"
User(8) = "Königin"
User(9) = "Knappe"
User(10) = "1ing"
User(11) = "1meister"
User(12) = "1stift"
User(13) = "1herr"
User(14) = "1frau"
User(15) = "1Miss"
User(16) = "1Mister"
User(17) = "1König"
User(18) = "1Königin"
User(19) = "1Knappe"
User(20) = "2ing"
User(21) = "2meister"
' User(22) = ""
User(22) = "2stift"
User(23) = "2herr"
User(24) = "2frau"
User(25) = "2Miss"
User(26) = "2Mister"
User(27) = "2König"
User(28) = "2Königin"
User(29) = "2Knappe"
If not (fso.FolderExists(UserVerz)) Then
FSO.CreateFolder(UserVerz)
End If
for i = 0 to 50
if User(i) = "" Then exit for
On Error Resume Next
FSO.CreateFolder(UserVerz & user(i) )
FSO.CreateFolder(UserVerz & user(i) & "\Temporary Internet Files")
FSO.CreateFolder(UserVerz & user(i) & "\Temp")
FSO.CreateFolder(UserVerz & user(i) & "\DAT")
FSO.CreateFolder(UserVerz & user(i) & "\neues")
FSO.CreateFolder(UserVerz & user(i) & "\nur hier")
On Error GoTo 0
next
MsgBox i & " Test-Verzeichnisse sind angelegt", , WScript.ScriptName
#########################################################################
>>> verz-suchen-loeschen.vbs <<<
'v2.4***************************************************
' File: Verz-Suchen-Loeschen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Skript ist Ergebnis einer Newsgroup-Anfrage: Auf einem
' Server müssen die 'Temporary Internet Files' in allen
' ...\user\... Verzeichnissen komplett gelöscht werden.
'*******************************************************
Option Explicit
Dim UserVerz, newpath, LoeschVerz
Dim i, n, index, Txt(), Text, Text1, TextX
Dim WSHShell, FSO
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
UserVerz = "C:\User"
LoeschVerz = "Temporary Internet Files"
' Temporary Internet Files
If not (fso.FolderExists(UserVerz)) Then
MsgBox UserVerz & " - Verzeichnis existiert nicht!", , WScript.ScriptName
WScript.Quit
End If
' Hole Ordner
newpath = fso.GetFolder(UserVerz)
index = 1
RecFolder index, newpath ' Hole Ordnerauflistung mit "Sub RecFolder"
For i = 1 to Ubound(Txt) ' Hole Ergebnis aus Txt(i) = Ordnerauflistung
Text = Text & Txt(i)
Next
Text1 = Split(Text, vbCRLF) ' Array Text in Zeilen aufteilen
Text = ""
n = 0
For i = 0 to Ubound(Text1)
if FSO.FolderExists(Text1(i) & "\" & LoeschVerz) then
fso.DeleteFolder(Text1(i) & "\" & LoeschVerz)
Text = Text & Text1(i) & vbCRLF
n = n +1
End If
Next
TextX = "In folgende " & n & " Verzeichnissen wurden """ & loeschVerz & """ gelöscht:" & vbCRLF & vbCRLF
TextX = TextX + Text
if not n = 0 then MsgBox TextX, , WScript.ScriptName
if n = 0 then MsgBox "Es gab keine """ & loeschVerz & """ in """ & UserVerz & """ ", , WScript.ScriptName
WScript.Quit
Sub RecFolder (idx, path)
' Autor: (c) Günter Born
'*********************************************************
' Rekursive Ordnerbearbeitung (hole Unterordner)
Dim oFolders, oSubFolder, oFolder
' Hole Folders-Auflistung
Set oFolders = fso.GetFolder(path)
Set oSubFolder = oFolders.SubFolders
Redim Preserve Txt(idx) ' redim String-Array
For Each oFolder in oSubFolder ' alle Ordner
Txt(idx) = Txt(idx) & path & "\" & oFolder.name & vbCRLF
' Unterordner rekursiv suchen
Call RecFolder (idx+1, path & "\" & oFolder.name)
Next
Set oFolders = Nothing ' Variable freigeben
Set oSubFolder = Nothing
End Sub
#########################################################################
>>> verzeichnisaltdelete.vbs <<<
'v3.7*****************************************************
' File: VerzeichnisAltDelete.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Löscht alle Verzeichnisse, die ab einem bestimmten Datum
'*********************************************************
Option Explicit
Dim Pfad, Alter
Pfad = "d:\setup"
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet, Skript wird also auch gelöscht
Pfad = "c:\temp"
Alter = 365 ' Verzeichnisse, die vor xxx Tagen angelegt wurden
MsgBox AlteVerzLoeschen (Pfad, Alter ) 'Function Aufruf und Ergebnisanzeige
AlteVerzLoeschen "c:\temp", 100 'Function Aufruf OHNE Ergebnisanzeige
' ~~~~~~
WScript.Quit
'*********************************************************
Function AlteVerzLoeschen (Pfad, Alter) ' Anfang
'*********************************************************
Dim fso, Txt, i, oSubFolder
Alter = FormatDateTime( now() - Alter ,2)
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!", , WScript.ScriptName
Exit Function
End If
AlteVerzLoeschen = "In " & UCase( Pfad ) & " wurden vor dem " & Alter & " angelegte Verzeichnisse gelöscht." & vbCRLF & vbCRLF
Set oSubFolder = fso.GetFolder( Pfad ).SubFolders
For Each i In oSubFolder
if DateDiff("d" , i.DateLastModified, Alter) > 0 then ' vor dem Alter geänderte Verzeichnisse
Txt = i.Path ' nach dem Löschen von i.Path ist auch i.Path gelöscht
AlteVerzLoeschen = AlteVerzLoeschen & i.Name & " " & vbTab & FormatDateTime( i.DateLastModified ,2)
On Error Resume Next
fso.DeleteFolder Txt, True
On Error GoTo 0
If not fso.FolderExists( Txt ) Then
AlteVerzLoeschen = AlteVerzLoeschen & vbCRLF
Else
AlteVerzLoeschen = AlteVerzLoeschen & " nicht gelöscht." & vbCRLF
End if
End If
Next
Set fso = nothing
Set oSubFolder = nothing
End Function ' AlteVerzLoeschen
#########################################################################
>>> w2krestart.vbs <<<
'v2.5*****************************************************
' File: W2kRestart.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Startet Win2k-System neu; erstellt ein Protokoll
' Startet nicht als Dienst; es muss ein geöffneter Desktop
' vorhanden sein
'*********************************************************
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".Log", 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
TextX = now & vbTab & WScript.ScriptName & " wird jetzt gestratet."
FileOut.WriteLine (TextX)
FileOut.Close
Set FileOut = Nothing ' Datei schließen
WshShell.sendkeys "^{ESC}" ' entspr. <Winows> - Taste
WshShell.sendkeys "{ESC}" ' Abbrechen - ak. Applikation ist jetzt der Desktop
WshShell.sendkeys "%{F4}" ' <Alt-F4> für den Desktop
' WshShell.sendkeys "n" ' n für Neustart deutsche NT4-Version
' WshShell.sendkeys "r" ' r für Restart englische W2k-Version
WshShell.sendkeys "n" ' n für Neustart deutsche W2k-Version
' *** nächste Zeile frei geben
' WshShell.sendkeys "{Enter}"
#########################################################################
>>> w2kshutdown.vbs <<<
'v2.5*****************************************************
' File: W2kShutDown.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Fährt Win2k-System herrunter; erstellt ein Protokoll
' Startet nicht als Dienst; es muss ein geöffneter Desktop
' vorhanden sein
'*********************************************************
set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".Log", 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
TextX = now & vbTab & WScript.ScriptName & " wird jetzt gestratet."
FileOut.WriteLine (TextX)
FileOut.Close
Set FileOut = Nothing ' Datei schließen
WshShell.sendkeys "^{ESC}" ' entspr. <Winows> - Taste
WshShell.sendkeys "{ESC}" ' Abbrechen - ak. Applikation ist jetzt der Desktop
WshShell.sendkeys "%{F4}" ' <Alt-F4> für den Desktop
' WshShell.sendkeys "c" ' c für Comp. Herrunter.. deutsche NT4-Version
' WshShell.sendkeys "s" ' s für ShutDown englische W2k-Version
WshShell.sendkeys "h" ' h für Herrunter.. deutsche W2k-Version
' *** nächste Zeile frei geben
' WshShell.sendkeys "{Enter}"
#########################################################################
>>> wav-to-mp3.vbs <<<
'v2.5*****************************************************
' File: wav-to-mp3.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverz. nach WAV-Dateien und wandelt diese
' mit LAME (http://www.mp3dev.org) in MP3-Dateien um,
' wenn es noch keine MP3-Datei mit selbigen Namen gibt.
' Anschließend werden die MP3's zur Kontrolle angepielt,
' zu denen WAV's existieren. Nach dem Schließen des MP3-
' Players wird gefragt, ob die WAV-Datei gleichen Namens
' gelöscht werden soll.
' Die MP3-Tag's werden richtig gesetzt, wenn die Verzeich-
' nisse den Namen des Interpreten haben - die WAV-Dateien
' tragen in ihrem Namen den Song-Titel.
'*********************************************************
Option Explicit
Dim Song, Interpret
Dim Text, Text1, Text2, index, Txt(), i, i1, i2, newpath
Dim fso, fo, fi, FileOut
Dim LameExe, LameParam, ZielVerz, Ziel, Quelle, WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Text = ""
LameExe = "C:\#DasDing\lame.exe"
ZielVerz = "C:\#DasDing"
If not fso.FileExists(LameExe) Then
MsgBox LameExe & " existiert nicht!", , WScript.ScriptName
WScript.Quit
End If
If not fso.FolderExists(ZielVerz) Then
MsgBox ZielVerz & " - Verzeichnis existiert nicht!", , WScript.ScriptName
WScript.Quit
End If
RecFolder 1, Zielverz ' Hole Ordnerauflistung mit "Sub RecFolder"
For i = 1 to Ubound(Txt) ' Hole Ergebnis aus Txt(i) = Ordnerauflistung
Text = Text & Txt(i)
Next
Text1 = Split(Text, vbCRLF) ' Array Text in Zeilen aufteilen
mp3Erstellen
' wavDelete
WScript.Quit
' Autor: (c) Günter Born
'*********************************************************
Sub RecFolder (idx, path)
' Rekursive Ordnerbearbeitung (hole Unterordner)
Dim oFolders, oSubFolder, oFolder
' Hole Folders-Auflistung
Set oFolders = fso.GetFolder(path)
Set oSubFolder = oFolders.SubFolders
Redim Preserve Txt(idx) ' redim String-Array
For Each oFolder in oSubFolder ' alle Ordner
Txt(idx) = Txt(idx) & path & "\" & oFolder.name & vbCRLF
' Unterordner rekursiv suchen
Call RecFolder (idx+1, path & "\" & oFolder.name)
Next
Set oFolders = Nothing ' Variable freigeben
Set oSubFolder = Nothing
End Sub
Sub wavDelete
' wenn .wav-Datei und .mp3-Datei mit gleichem Namen existiert,
' wird die .mp3-Datei zur Kontrolle abgespielt und vorgeschlagen,
' die .wav-Datei zu löschen
'*********************************************************
i2 = 0
Text = ""
Text2 = "Im Folgenden wird jede mp3-Datei abgespielt, zu der eine wav-Datei" & vbCRLF
Text2 = Text2 & "mit gleichem Namen existiert. Nach dem Schließen des Players wird " & vbCRLF
Text2 = Text2 & "gefragt, ob die entsprechende wav-Datei gelöscht werden soll"
MsgBox Text2, , WScript.ScriptName
For i = 1 to Ubound(Text1) -1
Set fo = fso.GetFolder(Text1(i))
Set fi = fo.Files ' Datei-Auflistung holen
For Each i1 In fi ' hole alle Dateien
if Ucase(Right(i1.name,4)) = ".WAV" then ' hole nur WAV - Dateien
Quelle = Text1(i) & "\" & i1.Name
Ziel = Mid(Quelle, 1, Len(Quelle) -4) & ".mp3"
if fso.FileExists(Quelle) AND fso.FileExists(Ziel) then ' wenn es zu einer .wav-datei
' eine .mp3-Datei gibt
i2 = i2+1
WSHShell.Run """" & Ziel & """", , True
Text2 = "Abgespielt wurde" & vbTab & vbTab & Ziel & vbCRLF & vbCRLF
Text2 = Text2 & "Soll " & vbTab & vbTab & Quelle & vbCRLF & vbCRLF
Text2 = Text2 & "gelöscht werden? "
Text2 = MsgBox (Text2, 4 + 256, WScript.ScriptName)
If Text2 = vbYes then ' wurde Yes gedrückt,
fso.DeleteFile(Quelle), True ' wird diese gelöscht
' WScript.Sleep 500 ' 500 Millisekunden warten
if fso.FileExists(Quelle) then MsgBox "ACHTUNG!" & vbCRLF & vbCRLF & Quelle & " konnte nicht gelöscht werden!"
if fso.FileExists(Quelle) then Text = Text & "(" & i2 & ") ungelöscht: " & vbTab & "..." & Mid(Quelle,Len(ZielVerz)+1) & vbCRLF
if not fso.FileExists(Quelle) then Text = Text & "(" & i2 & ") gelöscht: " & vbTab & "..." & Mid(Quelle,Len(ZielVerz)+1) & vbCRLF
Else
Text = Text & "(" & i2 & ") ungelöscht: " & vbTab & "..." & Mid(Quelle,Len(ZielVerz)+1) & vbCRLF
End If
End If
End If
Next
Set fo = Nothing ' Datei schließen
Next
If i2 = 0 then MsgBox "In " & newpath & "\... wurden keine mp3-Dateien gefunden, von denen es auch eine wav-Datei gibt.", , WScript.ScriptName
If i2 > 0 then MsgBox "Ordner " & newpath & "\..." & vbCRLF & vbCRLF & Text, vbOkonly + vbInformation, WScript.ScriptName
End Sub
Sub mp3Erstellen
' zu jeder .wav-Dateien eine .mp3-Dateien erstellen
'*********************************************************
i2 = 0
Text = ""
For i = 1 to Ubound(Text1) -1 ' zeilenweise (aus Text1)
Set fo = fso.GetFolder(Text1(i)) ' für jedes Verzeichnis
Set fi = fo.Files ' Datei-Listung holen
For Each i1 In fi ' hole alle Dateien aus Datei-Liste
if Ucase(Right(i1.name, 4)) = ".WAV" then ' hole nur WAV - Dateien
Quelle = Text1(i) & "\" & i1.Name
Song = Mid(i1.name, 1, Len(i1.name) -4)
Interpret = Mid(Text1(i), Len(ZielVerz) + 2)
Ziel = ZielVerz & "\" & Interpret & "\" & Song & ".mp3"
Ziel = Mid(Quelle, 1, Len(Quelle) -4) & ".mp3"
if fso.FileExists(Ziel) then ' wenn es zu einer .wav-datei eine
if fso.GetFile(Ziel).Size = 0 then ' 0 Byte große .mp3-Datei gibt
fso.DeleteFile(Ziel), True ' wird diese gelöscht
WSHShell.Popup "0 Byte große Datei " & Ziel & " wurde gelöscht", 3, WScript.ScriptName
End If
End If
if not fso.FileExists(Ziel) then ' wenn es von der .WAV- noch keine .mp3-Datei gibt
if not fso.GetFile(Quelle).Size/5 < fso.GetDrive(Left(Quelle,3)).AvailableSpace then
MsgBox "Auf " & ZielVerz & " steht nicht genügend Platz zur Verfügung!", , WScript.ScriptName
Exit Sub ' wenn weniger als 20% der Größe der Quelle-Datei auf
End If ' dem Ziellaufwerk frei ist - Abbruch
LameParam = " """ & Quelle & """ """ & Ziel & """ -b 128 "
LameParam = LameParam & " --tt """ & Song & """ --ta """ & Interpret & """"
' MsgBox LameExe & LameParam
WSHShell.Run LameExe & LameParam , , True
i2 = i2+1
Text = Text & "(" & i2 & ") " & vbTab & "..." & Mid(Ziel,Len(ZielVerz)+1) & vbCRLF
End If
End If
Next
Set fo = Nothing ' Datei schließen
Next
If i2 = 0 then MsgBox "In " & newpath & "\... wurden keine wav-Dateien zum Wandeln in mp3 gefunden.", , WScript.ScriptName
If i2 > 0 then MsgBox "Folgende Dateien wurden in " & ZielVerz & "\... erstellt " & vbCRLF & Text, vbOkonly + vbInformation, WScript.ScriptName
End Sub
#########################################################################
>>> winnt-or-win9x.vbs <<<
'v3.5***************************************************
' File: winnt-or-win9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'*******************************************************
' *****************************************************************
' etwas ausführlicher:
' *****************************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHEnvX = WSHShell.Environment("Process")
if WshEnvX("OS") = "Windows_NT" then
MsgBox "Windows_NT: NT4 oder W2k", , Titel
ScriptWeiter = "WinNT-XXX.vbs"
else
MsgBox "kein Windows_NT: Win9x, WinME", , Titel
ScriptWeiter = "Win9x-XXX.vbs"
end if
MsgBox ScriptWeiter, , WScript.ScriptName
' WshShell.run(ScriptWeiter)
' *****************************************************************
' ganz kurz:
' *****************************************************************
'
' Set WSHShell = WScript.CreateObject("WScript.Shell")
' Set WSHEnvX = WSHShell.Environment("Process")
' if WshEnvX("OS") = "Windows_NT" then WshShell.run("WinNT.VBS")
' if not WshEnvX("OS") = "Windows_NT" then WshShell.run("Win9x.VBS")
#########################################################################
>>> winverlogin.vbs <<<
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHEnvX = WSHShell.Environment("Process")
Titel = WScript.ScriptName
if WshEnvX("OS") = "Windows_NT" then
MsgBox "Windows_NT: NT4 oder W2k", , Titel
ScriptWeiter = "WinNT-XXX.vbs"
else
MsgBox "kein Windows_NT: Win9x, WinME", , Titel
ScriptWeiter = "Win9x-XXX.vbs"
end if
MsgBox ScriptWeiter, , Titel
' WshShell.run(ScriptWeiter)
#########################################################################
>>> winversp.vbs <<<
'v3.6***************************************************
' File: WinVerSP.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt WindowsNT-Version und Sp-Version
'*******************************************************
Option Explicit
Dim WSHShell, FSO, WSHNet
Dim ObjRemote, RootKey, ObjReg, oVal
Dim Text, Text1, Text2, TextX, KeyX, Server
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
If (fso.FileExists("REGOBJ.DLL")) Then ' Regobj.dll registrieren (erfordert AdminRechte)
TextX = "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" ' damit läßt sich besser auf die registry zugreifen
WshShell.Run (TextX),,TRUE ' muß im gleichen Verzeichnis wie das Script stehen
Set ObjReg = WScript.CreateObject("RegObj.Registry")
Else
MsgBox "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" & vbTab & " konnte nicht aufgerufen werden!", , WScript.ScriptName
WScript.Quit
End If
Text1 = "Von welchem Computer soll das Betriebssystem ermittelt werden?"
Server = wshnet.ComputerName
Server = InputBox (Text1, WScript.ScriptName, Server)
If Server = "" then Server = InputBox (Text1, WScript.ScriptName)
If Server = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Server = "" then WScript.Quit
Server = UCase(Server)
Set ObjRemote = objReg.RemoteRegistry( Server ) ' Objekt auf (Remote-) PC zeigen (REGOBJ.DLL)
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion"
Text1 = ""
Text2 = ""
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
if oVal.Name = "ProductName" then Text1 = oVal.Value
if oVal.Name = "CurrentVersion" then Text1 = "Windows NT " & oVal.Value
if oVal.Name = "CSDVersion" then Text2 = oVal.Value
Next
On Error GoTo 0
Text = "Der Computer " & vbTab & UCase(Server) & vbCRLF
Text = Text & "verwendet als Betriebssystem:" & vbCRLF & vbCRLF
Text = Text & Text1 & " " & Text2 & " " & vbCRLF
MsgBox Text, , WScript.ScriptName
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
#########################################################################
>>> wsh-info.vbs <<<
'v2.A*****************************************************
' File: wsh-info.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' zeigt Informationen zum WSH
'*********************************************************
TextX = vbCRLF
TextX = TextX & "WScript.ScriptName: " & vbTab & WScript.ScriptName & vbCRLF
TextX = TextX & "WScript.ScriptFullName: " & vbTab & WScript.ScriptFullName & vbCRLF
TextX = TextX & "WScript Path: " & vbTab & Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\") -1) & vbCRLF
set fso = CreateObject("Scripting.FileSystemObject")
TextX = TextX & "WScript Path: " & vbTab & fso.GetParentFolderName( WScript.ScriptFullName ) & vbCRLF
TextX = TextX & "WScript Path: " & vbTab & fso.GetFolder(".") & vbCRLF
TextX = TextX & "WScript.Applikation: " & vbTab & WScript.Application & vbCRLF
TextX = TextX & "WScript.Name: " & vbTab & WScript.Name & vbCRLF
TextX = TextX & "WScript.Version: " & vbTab & WScript.Version & vbCRLF
TextX = TextX & "WScript.FullName: " & vbTab & WScript.FullName & vbCRLF
TextX = TextX & "WScript.Path: " & vbTab & WScript.Path & vbCRLF
TextX = TextX & "ScriptEngine: " & vbTab & ScriptEngine & vbCRLF
TextX = TextX & "ScriptEngineMajorVersion: " & vbTab & ScriptEngineMajorVersion() & vbCRLF
TextX = TextX & "ScriptEngineMinorVersion: " & vbTab & ScriptEngineMinorVersion() & vbCRLF
TextX = TextX & "ScriptEngineBuildVersion: " & vbTab & ScriptEngineBuildVersion()
MsgBox TextX, , WScript.ScriptName
#########################################################################
>>> zeileindateitauschen.vbs <<<
'v2.7********************************************************
' File: ZeileInDateiTauschen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' In den Zeilen dürfen keine Anführungszeichen " stehen!
'
' dateiliste.txt stellt eine Liste der zu prüfenden Dateien
' bereit. Beim Skriptaufruf wird nach der zu suchenden
' Zeichenkette gefragt. Diese wird bei der Abfrage, wie die
' Zeile zukünftig heissen soll angezeigt und kann geändert
' werden. (Am einfachsten: zu suchende Zeile in die Zwischen-
' ablage übernehmen und beim Such-String eigeben.)
' (Ich habe damit in meinen HTML-Dateien u.a. das Bild und
' das <meta name="DC.Date" ... > Tag geändert.)
'************************************************************
Option Explicit
Dim fso, fo, fi, FinList, Fin, Fout
Dim Ziel, Quelle, WSHShell, ZielVerz
Dim TextX, Text1, Text2, Text3, Txt(), i, i1
Dim aHTML, eHTML, ZeileAlt, ZeileNeu, iText, DateiListe
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
ZielVerz = "m:\dieseyer.test"
ZielVerz = fso.GetParentFolderName( WScript.ScriptFullName )
DateiListe = ZielVerz & "\dateiliste.txt"
If not fso.FileExists( DateiListe ) Then MsgBox DateiListe & " existiert nicht!", , WSCript.ScriptName
If not fso.FileExists( DateiListe ) Then WScript.Quit
'---------------------------------------------------------
' DateiListe zeilenweise lesen (für Anzeige)
'---------------------------------------------------------
iText = ""
Set FinList = FSO.OpenTextFile( DateiListe, 1, true) ' Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
If iText = "" Then iText = TextX
Text1 = Text1 & vbCRLF & " " & TextX
End If
Loop
FinList.Close
Set FinList = nothing
TextX = ""
TextX = TextX & "In folgenden Dateien werden Zeilen ausgetauscht:" & vbCRLF
TextX = TextX & Text1
i = MsgBox (TextX, 4 + 32 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text1 = Text1 & "Wie lautet die komplette Zeile (ZeileAlt), die komplett erstezt werden soll?"
ZeileAlt = InputBox ( Text1 , WSCript.ScriptName , ZeileAlt)
If ZeileAlt = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
Text1 = ""
Text1 = Text1 & "Folgende Zeile (ZeileAlt) soll in den soeben gezeigten Dateien ausgetauscht werden."
Text1 = Text1 & "Ändern Sie jetzt diese Zeichenkette, um festzulegen, wie die Zeile in Zukunft (ZeileNeu) aussehen soll."
ZeileNeu = InputBox ( Text1 , WSCript.ScriptName , ZeileAlt)
If ZeileNeu = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
If ZeileAlt = ZeileNeu then
WSHShell.PopUp "Wenn ZeileNeu" & vbCRLF & " " & ZeileNeu & vbCRLF & "und ZeileAlt" & vbCRLF & " " & ZeileAlt & vbCRLF & "gleich sind, wird's nichts!", , WScript.Scriptname
WSCript.Quit
End If
TextX = "DAS IST DIE LETZTE WARNUNG!" & vbCRLF & vbCRLF & TextX
i = vbYes
' i = MsgBox (TextX, 4 + 48 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text2 = ""
'---------------------------------------------------------
' DateiListe zeilenweise lesen & Zeile(n) tauschen
'---------------------------------------------------------
Set FinList = FSO.OpenTextFile( DateiListe, 1, true) ' DateiListe-Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn DateiListe-Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
If not Text2 = "" then
Text1 = Text1 & vbCRLF & TextX & vbTab & " übersprungen"
Else
Text3 = ZeileInDateiTauschen (TextX, ZeileAlt, ZeileNeu) ' Function Aufruf
' if vbcancel = WSHShell.Popup (TextX & " . . . wurde bearbeitet.", 1, WScript.ScriptName, 1 + 64 ) Then Text2 = "übergehen"
Text1 = Text1 & vbCRLF & TextX & Text3
' Text1 = Text1 & vbCRLF & TextX & i
End If
End If
Loop
FinList.Close
Set FinList = nothing
MsgBox Text1, , WScript.ScriptName
WScript.Quit
'---------------------------------------------------------
Function ZeileInDateiTauschen (Datei, Suchen, Ersetzen)
'---------------------------------------------------------
Dim Fin, Fout, TextX, i
if not WScript.CreateObject("Scripting.FileSystemObject").FileExists(Datei) then
WScript.CreateObject("WScript.Shell").PopUp "Datei """ & Datei & """ nicht gefunden!", 1, WSCript.ScriptName, vbExclamation
ZeileInDateiTauschen = " " & vbTab & " nicht gefunden"
Exit Function
End If
WScript.CreateObject("Scripting.FileSystemObject").CopyFile Datei, Datei & ".tmp"
Set Fin = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Datei & ".tmp", 1, true) ' Datei zum Lesen öffnen
Set Fout = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Datei , 2, true) ' Datei neu anlegen & zum Schreiben öffnen
Do While Not (Fin.atEndOfStream) ' wenn Datei nicht zu Ende ist, weiter machen
TextX = Fin.Readline ' eine Zeile lesen
If InStr( TextX, Suchen ) > 0 Then
i = i + 1
Fout.WriteLine Ersetzen
Else
Fout.WriteLine TextX
End If
Loop
Fin.Close
Set Fin = Nothing ' Datei schließen
Fout.Close
Set Fout = Nothing ' Datei schließen
If i > 0 Then
' WScript.CreateObject("WScript.Shell").PopUp "Austausch in Datei """ & Datei & """ abgeschlossen " , 1, WSCript.ScriptName, vbExclamation
ZeileInDateiTauschen = " " & vbTab & i & " Zeile(n) getauscht."
Else
' WScript.CreateObject("WScript.Shell").PopUp "Die angegebene Zeile ==|" & Suchen & "|== konnte nicht in der Datei """ & Datei & """ gefunden werden." , 5, WSCript.ScriptName, vbExclamation
ZeileInDateiTauschen = " " & vbTab & " Zeile nicht gefunden."
End If
' WSCript.Sleep 2
'_____________________________________________
' folgende Zeile löscht die Sicherheitskopien
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile Datei & ".tmp", True
End Function ' ZeileInDateiTauschen
#########################################################################
>>> adminstart.vbs <<<
'*************************************************************************
'* AdminStart.vbs
'*
'* Führt Scripte und Programme unter einem anderen Useraccount aus.
'* Alle notwendigen Angaben wie Benutzername und Passwort
'* können über die Kommandozeile mitgegeben werden.
'*
'* Es können Scripte für WSCRIPT und CSCRIPT gestartet werden.
'*
'* Known Limits
'* ============
'*
'* - Das Script ist für Deutsch ausgelegt. Bei anderen Sprachen muss die
'* Variable strConsole entsprechend angepasst werden.
'*
'* - Scripte für die Konsole können nur gestartet werden, wenn das Passwort
'* als Parameter mitgegeben wird.
'*
'* - Die Wartezeiten zum Aktivieren der Applikationsfenster kann bei
'* Bedarf über die beiden Variablen intSleepShort (Wartezeit nach
'* AppActivate bis zum Senden von Tastenanschlägen) und intSleepLong
'* (Wartezeit nach Programmstart runas/cmd) verändert werden.
'*
'* - Werden Useraccount und Passwort fix einprogrammiert, muss das
'* Script mit dem Encoder codiert werden.
'*
'*
'* Starparameter (Reihenfolge spielt keine Rolle)
'* =============
'*
'* /U Angabe des Useraccounts. Der Name muss komplett notiert werden und
'* ohne Leerschlag an /U angefügt werden. Parameter ist zwingend.
'* /Udomain\administrator oder /Ucomputername\administrator
'*
'* /S Angabe der Scripts, das gestartet werden soll. Wenn das Script im
'* gleichen Verzeichnis liegt wie AdminStart.vbs, muss der Pfad zum
'* Script nicht angegeben werden. Im andern Fall ist das Script mit
'* der kompletten Pfadangabe zu übergeben. Parameter ist zwingend.
'* /Smeinscript.vbs oder /S\\server\ablage$\meinscript.vbs
'*
'* Wichtig: Wenn für das Script selbst Parameter übergeben werden
'* müssen, muss der ganze Schalter /S in Anführungszeichen gefasst
'* werden: "/Smeinscript.vbs /parameter2 /parameter2"
'*
'* /P Übergibt das Passwort zum Useraccount. Ohne Angabe des Passwortes
'* wird es von RunAs.Exe über die Konsole abgefragt.
'*
'* /C Lässt das Script mit CScript ablaufen oder startet ein Windows-
'* Programm. Ohne diesen Schalter wird immer ein Script mit WScript
'* gestartet.
'* /C = starte Script mit CSCRIPT
'* /CP = starte eine Windows-Programm. In diesem Fall muss mit /S
'* der komplette Pfad angebenen werden -> /sc:\winnt\notepad.exe
'*
'* (C) 2002 by EagleSoft Ltd. / Roland Weisskopf
'*
'*************************************************************************
'**Start Encode**
'Option Explicit
Dim strInterpreter(1)
Dim strRunAsPrefix, strConsole, strScript, strUser, strPass, strRunCommand
Dim objShell
Dim intLoop, intMode, intSleepShort, intSleepLong
Dim blnPass
Const cCScript = 0
Const cWScript = 1
Const cProgram = 2
'* Presets zum Anpassen
'###############################################
'# Werte User und PW nach Bedarf fix eintragen
'# und mit SCRENC dieses File codieren
'###############################################
' Useraccount: domain\account o. machine\account
strUser = ""
' Passwort
strPass = ""
'###############################################
' Pfad, Name und Parameter für das Script
strScript = ""
' Sprachenanpassung von 'ausgeführt als'
strConsole = "cmd.exe /k ( ausgeführt als "
' Wartezeit nach Fensterfokusierung
intSleepShort = 250
' Wartezeit nach Run-Command
intSleepLong = 500
' Standardmodus
intMode = cWScript
'* Presets (nicht ändern!!)
strRunAsPrefix = GetSystem32 & "\runas /user:"
strInterpreter(0) = "cmd.exe /k"
strInterpreter(1) = "wscript "
blnPass = vbFalse
Set objShell = WScript.CreateObject("WScript.Shell")
'* Command Line Parameter auswerten
if Wscript.Arguments.Count > 0 then
for intLoop = 0 to Wscript.Arguments.Count-1
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/C" then
intMode = cCScript
if right(ucase(WScript.Arguments.Item(intLoop)),1) = "P" then intMode=cProgram
end if
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/U" then
if len(WScript.Arguments.Item(intLoop))>2 then
strUser = right(WScript.Arguments.Item(intLoop),len(WScript.Arguments.Item(intLoop))-2) & " "
end if
end if
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/P" then
if len(WScript.Arguments.Item(intLoop))>2 then
strPass = right(WScript.Arguments.Item(intLoop),len(WScript.Arguments.Item(intLoop))-2)
blnPass = vbTrue
end if
end if
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/S" then
if len(WScript.Arguments.Item(intLoop))>2 then
strScript = right(WScript.Arguments.Item(intLoop),len(WScript.Arguments.Item(intLoop))-2)
Dim intPosP
intPosP=inStr(1,strScript,":\",vbTextCompare)
if intPosP=0 or intPosP>4 then
intPosP=inStr(1,strScript,"\\",vbTextCompare)
if intPosP=0 or intPosP>3 then strScript = strScriptPath & "\" & strScript
end if
end if
end if
next
end if
if strScript = "" then MissingParameter
if strUser = "" then MissingParameter
if right(strUser,1)<>" " then strUser = strUser & " "
if strPass<>"" then blnPass = vbTrue
if (intMode=cCScript) and (not blnPass) then MissingParameter
select case intmode
case cCScript
strRunCommand = strRunAsPrefix & strUser & chr(34) & strInterpreter(intMode) & chr(34)
case cWScript
strRunCommand = strRunAsPrefix & strUser & chr(34) & strInterpreter(intMode) & strScript & chr(34)
case cProgram
strRunCommand = strRunAsPrefix & strUser & chr(34) & strScript & chr(34)
end select
objShell.Run strRunCommand
WScript.Sleep intSleepLong
if blnPass then
objShell.AppActivate GetSystem32 & "\runas.exe"
WScript.Sleep intSleepShort
objShell.Sendkeys strPass & "{enter}"
select case intMode
case cCScript
WScript.Sleep intSleepLong
objShell.AppActivate strConsole & strUser & ")"
WScript.Sleep intSleepShort
objShell.Sendkeys "cscript " & chr(34) & strScript & chr(34) & "{enter}"
end select
end if
Set objShell = nothing
WScript.Quit
'********************************************************************
'* Sub MissingParameter
'* Benötigte Parameter wurden nicht übergeben
'********************************************************************
Private Sub MissingParameter
WScript.Echo "Es fehlt mindestens einer der benötigten Startparameter. Prüfe die Eingabe für /U, /P und /C."
WScript.Quit
End Sub
'********************************************************************
'* Function strScriptPath
'* Ermittle den Serverpfad des aktuellen Scripts
'********************************************************************
Private Function strScriptPath
strScriptPath = left(Wscript.ScriptFullName,len(Wscript.ScriptFullName)-len(Wscript.ScriptName)-1)
End Function
'********************************************************************
'* Function GetSystem32
'* Gibt das lokale System32-Verzeichnis zurück
'********************************************************************
Private Function GetSystem32
Dim strTemp
strTemp = strEnviron("windir")
GetSystem32 = strTemp & "\system32"
End Function
'********************************************************************
'* Function strEnviron
'* Gibt Umgebungsvariablen von Windows zurück
'********************************************************************
Private Function strEnviron(strVarName)
Dim objWindows
Set objWindows = WScript.CreateObject("WScript.Shell")
strEnviron = objWindows.ExpandEnvironmentStrings("%" + strVarName + "%")
Set objWindows = Nothing
End Function
#########################################################################
>>> changefilenames.vbs <<<
'v3.5***************************************************
' File: changefilenames.vbs
' Autor: Peter Ladnar
' dieseyer.de
'
' Bilddateien eines Verz. umbennen und durchnummerieren
'*******************************************************
' zum debugen: script //d name.vbs stop
Dim strNewName, objPath, intValue
strNewName = Empty
Begruessung()
FolderAuswahl
ShowFolderList objPath
ShowFileList objPath
MsgBox "Alle Dateien umbenannt, fertig ",0,"Digi-Photo Tool, Ende"
Function Begruessung()
Dim intValue, strMessage
strMessage = "Du hast auch eine digitale Kamera und dich nervt es auch, die Dateinamen" & vbCrLf
strMessage = strMessage & "mühselig manuell in sinnvolle Namen zu ändern?" & vbCrLf & vbCrLf
strMessage = strMessage & "Dann ist dieses Tool genau richtig für dich! "
strMessage = strMessage & "Es benennt alle Dateien eines" & vbCrLf & "wählbaren Verzeichnisses "
strMessage = strMessage & "in einen neuen, durchnummerierten Namen um." & vbCrLf & vbCrLf
strMessage = strMessage & "Tool starten ?"
intValue = MsgBox(strMessage,4, WScript.Scriptname & " - Begrüssung")
If (intValue = 7) Then
WScript.Quit
End If
End Function
Sub FolderAuswahl
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
Const OverWriteFiles = True
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder (WINDOW_HANDLE, "Ordner mit Bildern auswählen:", NO_OPTIONS, "C:\ d:\")
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
End Sub
Sub ShowFolderList(folderspec)
Dim fs, f, f1, fc, s, x
x = 0
s = objPath & ":" & vbCrLf & vbCrLf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
If (x < 10) Then
s = s & f1.name
s = s & vbCrLf
x = x+1
End If
Next
If (x = 0) Then
MsgBox "Verzeichnis enthält keine Dateien !! ",0, WScript.Scriptname & " - Ende"
WScript.Quit
End If
s = s & "..." & vbCrLf & "diese und alle anderen Dateien umbenennen in:"
strNewName = InputBox (s,WScript.Scriptname & " - Neuer Dateiname","NeuerName")
If (IsEmpty(strNewName) = True) Then
WScript.Quit
End If
End Sub
Sub ShowFileList(folderspec)
Dim fs, f, f1, fc, s
s = 1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
RenameFile f1, s
s = s+1
Next
End Sub
Function RenameFile(fileName, x)
Dim objFSO, strDest, strName, strExt, arrLen, intLen, strMessage
arrLen = Array("000","00","0")
strName = "\" & strNewName
strExt = Lcase(right(fileName,4))
intLen = Len(x)
Select Case strExt
Case ".jpg",".bmp",".gif",".tif"
intValue = 6
Case Else
strMessage = fileName & vbCrLf & "ist keine Bilddatei, trotzdem umbennen?"
intValue = MsgBox(strMessage,4,WScript.Scriptname & " - Keine Bilddatei")
End Select
If (intValue = 7) Then
Exit Function
End If
Select Case intLen
Case 1 strName = strName & arrLen(0) & x
Case 2 strName = strName & arrLen(1) & x
Case 3 strName = strName & arrLen(2) & x
Case Else strName = strName & x
End Select
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDest = objPath & strName & strExt
objFSO.CopyFile fileName , strDest , OverWriteFiles
objFSO.DeleteFile fileName
End Function
#########################################################################
>>> dez2hex.vbs <<<
'v3.3*****************************************************
' File: Dez2Hex.vbs
' Autor: Hubert Daubmeier / hubertd@neusob.de
' http://www.neusob.de/scripting
'
' Wandelt eine Dezimal- in eine Hex-Zahl; für Zahlen von
' 0 bis 100 Milliarden. Bei Fließkommazahlen größer 2^53
' könnte es zu Rundungsfehlern kommen. Bei Zahlen zw.
' 2^53 bis 2^96 müßte man evtl. auf den Datentyp Währung
' ausweichen.
'*********************************************************
Option Explicit
MsgBox BigHex( 255 )
MsgBox BigHex( 2^52+1 )
MsgBox BigHex( 2^53-1 )
MsgBox BigHex( 2^53+1 )
Function BigHex(ByVal X)
Dim A, D
BigHex = ""
A = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")
Do While X > 0
D = X - 16 * Fix(X / 16)
BigHex = A(D) & BigHex
X = (X - D) / 16
Loop
If BigHex = "" Then BigHex = "0"
End Function
#########################################################################
>>> dir2htmlview.vbs <<<
'v3.5 ****************************************************************
' Funktion:
' Das Skript öffnet eine HTML-Datei und zeigt in einem Frame
' die Dateien des gedroppten Ordners an. Benötigt ein Unter-
' verzeichnis (FrameScroller) mit einigen Spezialdateien.
'
' Übergebene Argumente :
' - kein Argument übergeben: Nachfrage: aktuelles Verzeichnis oder Abbruch.
' - nur ein Argument übergeben (eine Datei): übergeordneten
' Ordner holen, alle Dateien darin durchgehen
' - nur ein Argument übergeben (einen Ordner): ganzen Ordner
' holen, alle Dateien darin durchgehen
' - mehrere Argumente übergeben: Argumente einzeln auswerten:
' ist das aktuelle Argument eine Datei, diese eintragen
' (aber nicht den übergeordneten Ordner, dies nur bei einer
' einzigen übergebenen Datei)
' - ist das aktuelle Argument ein Ordner, alle Dateien dieses
' Ordners eintragen.
'
' Man kann also:
' - Drei Html-Dateien aus einem Ordner (mit vielen Html-Dateien)
' droppen, um nur in diesen dreien zu blättern.
' - Ordner droppen, um alle html/Text/Bild-Dateien darin zu sehen
' - eine Datei droppen, um alle in ihrem Verzeichnis zu sehen
' - einen Ordner und zwei Dateien droppen: man sieht alle
' Dateien in diesem Verzeichnis und die beiden Dateien (aber
' keine weiteren Dateien aus ihrem Ordner; s.o.)
'
' Ferner kann man:
' - die erlaubten Endungen (htm, html, txt...) verändern
' - das Script auf den Desktop legen und per Drag und Drop starten
' - eine Verknüpfung auf dieses Script in den SendTo-Ordner kopieren
' und per rechter Maustaste | Senden an starten
' - dieses Script perBatch-Datei starten
'
' Erfordert: WSH 2.0 / 5.5, Internet Explorer, Spezialdateien
'
' Version um 13:35 am 29.05.2003.
'
' Ralf Nebelo (c't 24 / 2001, S.264) & Christoph Römhild
' (veröffentlicht auf http://dieseyer.de)
' ****************************************************************
Option Explicit
' ****************************************
Const strErlaubte_Endungen = ".htm.html.shtml.txt.pdf.jpg.jpe.gif.tif.png.bmp" ' In der Form: ".htm.html" (mit Punkten)
Const strVersion = "um 13:35 am 29.05.2003" ' z.B. "um 17:08 am 24.05.2003"
Const strTitel = "Verzeichnis als Internet-Explorer Frame zeigen" ' Titel
Dim objFS ' Filesystem-Object
' Aufruf Main
Main
' ****************************************
Sub Main
' Pfade und Dateien
Const strConstPathFolder = "\FrameScroller" ' der Folder
Const strConstPath1 = "\LoadTMP.js" ' Temporäre Datei in der Form "\FrameScroller\LoadTMP.js"
Const strConstPath2 = "\Start.html" ' Framerahmen in der Form "\FrameScroller\Start.html"
Const strConstPath3 = "\Loader.js" ' Javascript in der Form "\FrameScroller\Loader.js"
Dim strDateiListe ' zu erstellender String
Dim strMeldung ' für MsgBox-Meldungen
Dim strArg ' Argumente von Kommandozeile
Dim strPathScript ' Pfad des Skriptes
Dim strPathFolder ' Pfad des Ordners FrameScroller (analog zu oben)
Dim strPath1 ' Temporäre Datei (analog zu oben)
Dim strPath2 ' Framerahmen (analog zu oben)
Dim strPath3 ' Javascript (analog zu oben)
' Init ********************************************
' Filesystem-Object holen
Set objFS = WScript.CreateObject("Scripting.FileSystemObject")
' Pfade erstellen
strPathScript = objFS.GetParentFolderName( wscript.ScriptFullname )
strPathFolder = strPathScript + strConstPathFolder
strPath1 = strPathFolder + strConstPath1
strPath2 = strPathFolder + strConstPath2
strPath3 = strPathFolder + strConstPath3
' String strDateiListe erstellen ******************
' strDateiListe ist die zu bildende Liste
' sieht so aus : strDateiListe = "MeineDateien = new Array("file://c:/filme1.htm","file://c:/weltall1.htm","file://c:/texte1.htm");"
' Anfang der Zeile setzen :
strDateiListe = "MeineDateien = new Array("
' Je nach Anzahl der übergebenen Argumente : ******
' Dieser Block startet alles weitere wichtige
If Wscript.Arguments.Count = 0 Then
' Frage stellen
strMeldung = "Keine Dateien oder Ordner gedroppt. " & vbNewLine
strMeldung = strMeldung + "Soll statt dessen der Ordner des Skriptes in einem Frame dargestellt werden?"
if MsgBox (strMeldung, vbyesnocancel + vbquestion, strTitel) = vbyes then
call EinElementAuswerten (strPathScript, strDateiListe)
else
WScript.Quit ' Abbruch
end if
Elseif Wscript.Arguments.Count = 1 Then
' es wurde nur ein Argument übergeben; wenn Datei, dann übergeordneter Ordner; wenn Ordner, dann so lassen
strArg = OrdnerAusArgument ( 0 )
' Ist es Datei oder Ordner?
if strArg = "" then
' Weder Datei noch Ordner (z.B. /?)
AuswertungKommandzeilenParameter ( Wscript.Arguments(0) ) ' ggf. Hilfe oder Version anzeigen
WScript.Quit ' Abbruch
else
' Alles ok, strArg ist ein Pfad / Datei oder Ordner o.ä.
call EinElementAuswerten ( strArg, strDateiListe )
end if
Elseif Wscript.Arguments.Count > 1 Then
' Alles ok
call AlleArgumenteDurchgehen ( strDateiListe )
Else
' Fehler (Count < 0 oder ähnliches)
msgbox "Unbekannte Anzahl der Argumente", vbInformation, strTitel
End If ' End If von Je nach Anzahl der übergebenen Argumente
' ggf. Abbruch ************************************
If FolderExistsExtended (strPathFolder) = False Then WScript.Quit
If FileExistsExtended (strPath2) = False Then WScript.Quit
If FileExistsExtended (strPath3) = False Then WScript.Quit
If Len(strDateiListe) <= 25 then
strMeldung = "Keine Dateien gefunden."
msgbox strMeldung, vbcritical, strTitel
WScript.Quit ' Abbruch
end if
' write strDateiListe to LoadTMP.js ***************
call SchreibeStringInEinFile (strDateiListe, strPath1)
' Explorer starten ********************************
StarteProgramm "iexplore.exe", strPath2
end sub ' Ende von Main
' ************************************************************
' ************************************************************
' zentrale Subs
sub AlleArgumenteDurchgehen( strDateiListe )
' wird nur von Main gestartet
Dim intI
Dim strArg
' Alle Argumente durchgehen
For intI = 0 To Wscript.Arguments.Count - 1
' Argument einlesen
strArg = WScript.Arguments( intI )
' Argument auswerten
call EinElementAuswerten (strArg, strDateiListe )
Next ' Next Argument
end sub
' ************************************************************
sub EinElementAuswerten (strArg, strDateiListe )
' wird von Main oder von AlleArgumenteDurchgehen gestartet
Dim objFile
' Argument auswerten
If objFS.FolderExists( strArg ) = True Then
' Es ist ein Ordner :
' Alle Dateien im Ordner durchgehen
For Each objFile In objFS.GetFolder( strArg ).Files
call SchreibeString ( objFile, strDateiListe )
Next ' Next Datei
ElseIf objFS.FileExists(strArg) = True Then
' Es ist eine Datei : Direkt schreiben:
Set objFile = objFS.GetFile(strArg)
Call SchreibeString ( objFile, strDateiListe )
Else
' Fehler: weder noch (dieses Argument übergehen, mit dem nächsten fortfahren)
msgbox "Datei oder Ordner existiert nicht: " & vbnewLine & strArg, vbinformation, strTitel
End If
end sub
' ************************************************************
sub SchreibeString ( objLocalDatei, strDateiListe )
' wird nur von EinElementAuswerten gestartet
Dim strFile
Dim strEndung
' Dateiname holen
strFile = LCase(objLocalDatei.path)
' Endung einlesen
strEndung = objFS.GetExtensionName(strFile)
' Wenn Endung erlaubt (ignoriert also alle zips und exes etc.); Dateien ohne Endung ignorieren
If InStr ( 1, strErlaubte_Endungen, strEndung ) > 0 and strEndung <> "" Then
' dann zu bildende Liste ergänzen; dabei muss \ durch / ersetzt werden; chr(34) ist ein "
strDateiListe = strDateiListe + chr(34) + "file://" + Replace (strFile,"\","/") + chr(34) + ","
End If
end Sub
' ************************************************************
' ************************************************************
' Hilfs-subs
function OrdnerAusArgument ( intNummerDesArguments )
' Argument Nummer "intNummerDesArguments" der Kommandozeile lesen;
' wenn Ordner, diesen zurückgeben;
' wenn Datei, deren übergeordneten (enthaltenden) Ordner zurückgeben.
Dim strPath ' Puffer für Rückgabewert
Dim objFolder ' Object Folder
Dim objFile ' Object File
Dim strArgument ' Argument aus Kommandozeile
' Wurden Argumente übergeben?
If WScript.Arguments.count <= 0 then
' Nein, nichts, Rückgabewert zwischenspeichern
strPath = ""
Else
' Ja, es wurde etwas übergeben; Argument speichern
strArgument =WScript.Arguments( intNummerDesArguments )
End if
' Ist es eine Datei?
If objFS.FileExists (strArgument) then
' Ja, Datei :
set objFile = objFS.GetFile(strArgument)
' Rückgabewert zwischenspeichern
strPath = objFS.getParentFolderName (objFile.shortpath)
' Wenn nicht: Ist es ein Ordner?
ElseIf objFS.FolderExists (strArgument) then
' Ja, Ordner :
Set objFolder = objFS.GetFolder(strArgument)
' Rückgabewert zwischenspeichern
strPath = objFolder.ShortPath
Else
' Weder Datei noch Ordner (z.B. gelöschte Datei); Rückgabewert zwischenspeichern
strPath = ""
End if
' Rückgabewert setzen
OrdnerAusArgument = strPath
End function
' ************************************************************
sub AuswertungKommandzeilenParameter (strArg)
' Nur einen Parameter, der weder Datei noch Ordner ist, auswerten.
' z.B. für /? etc.
Dim strMeldung ' für MsgBox-Meldungen
Dim strArgAlsLCase ' in Kleinbuchstaben
' vorbereiten
' Kleinbuchstaben
strArgAlsLCase = Trim( LCase ( strArg ) )
' Das vbs Case kennt kein oder (Or), deshalb hier vereinheitlichen :
if strArgAlsLCase = "/?" or strArgAlsLCase ="?" or _
strArgAlsLCase ="/help" or strArgAlsLCase ="help" or _
strArgAlsLCase ="/h" or strArgAlsLCase ="h" or _
strArgAlsLCase ="/hilfe" or strArgAlsLCase ="hilfe" then
strArgAlsLCase = "/?"
end if
if strArgAlsLCase = "/v" then
strArgAlsLCase = "/version"
end if
' auswerten
select Case strArgAlsLCase
case "/?"
strMeldung = "Hilfe zu dir2htmlview." & vbnewline
strMeldung = strMeldung & vbnewline & "Schreibt ein Dateininhaltsverzeichnis des gedroppten Ordners in ein Frame." & vbnewline
strMeldung = strMeldung & "Braucht ein Unterverzeichnis (FrameScroller) mit einigen Spezialdateien."
MsgBox strMeldung, vbInformation, strTitel
case "/version"
strMeldung = "Version lautet " + strVersion
msgbox strMeldung , vbInformation, strTitel
case else
strMeldung = "Keine Dateien oder Ordner gedroppt. Das Skript konnte Ihren Parameter nicht erkennen. "
strMeldung = strMeldung & vbnewline & "Der Parameter lautete: " & vbnewline
strMeldung = strMeldung & strArg & vbnewline & "Eventuell ist die Datei oder der Ordner gelöscht worden."
strMeldung = strMeldung & vbnewline & vbnewline & "Verwenden Sie /? für Hilfe."
msgbox strMeldung, vbcritical, strTitel
end select
end sub
' ************************************************************
function FolderExistsExtended (strPathFolder )
Dim strMeldung ' für MsgBox-Meldungen
FolderExistsExtended = true
If objFS.FolderExists ( strPathFolder ) = False Then
strMeldung = "Ein wichtiger Ordner existiert nicht. "
strMeldung = strMeldung & vbnewline & "Deshalb Abbruch." & vbnewline
strMeldung = strMeldung & "Name des Pfads: " & vbnewline & strPathFolder & "."
MsgBox strMeldung, vbInformation, strTitel
FolderExistsExtended = false
End If
end function
' ************************************************************
function FileExistsExtended (strPath)
Dim strMeldung ' für MsgBox-Meldungen
FileExistsExtended = true
If objFS.FileExists ( strPath ) = False Then
strMeldung = "Eine wichtige Datei existiert nicht. "
strMeldung = strMeldung & vbnewline & "Deshalb Abbruch." & vbnewline
strMeldung = strMeldung & "Pfad der Datei: " & vbnewline & strPath & "."
MsgBox strMeldung, vbInformation, strTitel
FileExistsExtended = false
End If
end function
' ************************************************************
sub SchreibeStringInEinFile (strDateiListe, strPath1)
' fertigen String aus RAM in die Datei auf der Festplatte schreiben
Dim objTextFile
' letztes Komma wieder weg :
strDateiListe = Left ( strDateiListe, Len(strDateiListe)-1 )
' Klammer am Ende setzen :
strDateiListe = strDateiListe + ");"
' write strDateiListe to LoadTMP.js ***************************
' Datei erstellen, alte überschreiben :
Set objTextFile = objFS.OpenTextFile(strPath1, 2, True)
' schreiben :
objTextFile.WriteLine(strDateiListe)
' schliessen :
objTextFile.Close
end sub
' ************************************************************
sub StarteProgramm (Path, Parameter)
' startet z.B. den Internet Explorer
Dim objShell
Dim strAufruf
Set objShell = WScript.CreateObject ("WScript.Shell")
strAufruf = Path & " " & Parameter
' starte Programm mit Parameter und Vollbild und warte nicht
objShell.run strAufruf, 3, True
end sub
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#########################################################################
>>> fso-beispielcode.vbs <<<
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' FileSystemObject-Beispielcode
'
' Copyright 1998 Microsoft Corporation. Alle Rechte vorbehalten.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Informationen zur Codequalität:
'
' 1) Der folgende Code führt eine Anzahl von Zeichenfolgenmanipulationen
' aus. Dabei werden kurze Zeichenfolgen mit dem Operator "&" verkettet.
' Da Zeichenfolgenverkettungen lange dauern, ist dieser Code nicht sehr
' effizient. Es ist jedoch ein sehr gängiger Weg zum Schreiben von Code.
' Dieser Weg wird hier verwendet, da dieses Programm intensive Fest-
' plattenoperationen ausführt und diese Operationen wesentlich langsamer
' als die Operationen zum Verketten der Zeichenfolgen im Speicher sind.
' Beachten Sie auch, dass dieser Code zu Demonstrationszwecken geschrieben
' wurde.
'
' 2) Es wird "Option Explicit" verwendet, da der Zugriff auf deklarierte
' Variablen etwas schneller als der Zugriff auf undeklarierte Variablen
' ist. Außerdem wird so das Entstehen von Fehlern im Code verhindert,
' wie z. B. durch den Schreibfehler DriveTypeCDORM statt DriveTypeCDROM.
'
' 3) In diesem Code wurde keine Fehlerbehandlung vorgesehen. Der Code ist
' so besser lesbar. Obwohl Vorkehrungen zum Verhindern von Fehlern in
' normalen Fällen getroffen wurden, können sich Dateisysteme eventuell
' unvorhersehbar verhalten. In kommerziellem Code sollten Sie "On Error
' Resume Next" und das Err-Objekt verwenden, um mögliche Fehler abzufangen.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Einige hilfreiche globale Variablen
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Tabulator
Dim NeueZeile
Const TestLW = "C"
Const TestDateiPfad = "C:\Test"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Von Drive.DriveType zurückgegebene Konstanten
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const DriveTypeWechselbar = 1
Const DriveTypeFest = 2
Const DriveTypeNetzwerk = 3
Const DriveTypeCDROM = 4
Const DriveTypeRAMLW = 5
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Von File.Attributes zurückgegebene Konstanten
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const AttributNormal = 0
Const AttributSchreibgesch = 1
Const AttributVersteckt = 2
Const AttributSystem = 4
Const AttributDatentr = 8
Const AttributVerzeichnis = 16
Const AttributArchiv = 32
Const AttributAlias = 64
Const AttributKomprimiert = 128
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Konstanten zum Öffnen von Dateien
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const DateiOeffnenZumLesen = 1
Const DateiOeffnenZumSchreiben = 2
Const DateiOeffnenZumAnfuegen = 8
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ZeigeLWTyp
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den Laufwerktyp eines angegebenen Drive-Objekts beschreibt.
'
' Zeigt Folgendes
'
' - Drive.DriveType
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ZeigeLWTyp(LW)
Dim S
Select Case LW.DriveType
Case DriveTypeWechselbar
S = "Wechselmedium"
Case DriveTypeFest
S = "Fest"
Case DriveTypeNetzwerk
S = "Netzwerk"
Case DriveTypeCDROM
S = "CD-ROM"
Case DriveTypeRAMLW
S = "RAM-Laufwerk"
Case Else
S = "Unbekannt"
End Select
ZeigeLWTyp = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ZeigeDateiAttribute
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die Datei- oder Ordnerattribute beschreibt.
'
' Zeigt Folgendes
'
' - File.Attributes
' - Folder.Attributes
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ZeigeDateiAttribute(Datei) ' Datei kann Datei oder Ordner sein
Dim S
Dim Attr
Attr = Datei.Attributes
If Attr = 0 Then
ZeigeDateiAttribute = "Normal"
Exit Function
End If
If Attr And AttributVerzeichnis Then S = S & "Verzeichnis "
If Attr And AttributSchreibgesch Then S = S & "Schreibgeschützt "
If Attr And AttributVersteckt Then S = S & "Versteckt "
If Attr And AttributSystem Then S = S & "System "
If Attr And AttributDatentr Then S = S & "Datenträger "
If Attr And AttributArchiv Then S = S & "Archiv "
If Attr And AttributAlias Then S = S & "Alias "
If Attr And AttributKomprimiert Then S = S & "Komprimiert "
ZeigeDateiAttribute = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeLWInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status der verfügbaren Laufwerke beschreibt.
'
' Zeigt Folgendes
'
' - FileSystemObject.Drives
' - Iteration der Drives-Auflistung
' - Drives.Count
' - Drive.AvailableSpace
' - Drive.DriveLetter
' - Drive.DriveType
' - Drive.FileSystem
' - Drive.FreeSpace
' - Drive.IsReady
' - Drive.Path
' - Drive.SerialNumber
' - Drive.ShareName
' - Drive.TotalSize
' - Drive.VolumeName
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeLWInformation(FSO)
Dim LWs
Dim LW
Dim S
Set LWs = FSO.Drives
S = "Anzahl der Laufwerke:" & Tabulator & LWs.Count & NeueZeile & NeueZeile
' Erstellt die erste Zeile des Berichts.
S = S & String(2, Tabulator) & "Laufwerk"
S = S & String(3, Tabulator) & "Datei"
S = S & Tabulator & "Gesamt"
S = S & Tabulator & "Frei"
S = S & Tabulator & "Verfügbar"
S = S & Tabulator & "Seriennummer" & NeueZeile
' Erstellt die zweite Zeile des Berichts.
S = S & "Laufwerkbuchstabe"
S = S & Tabulator & "Pfad"
S = S & Tabulator & "Typ"
S = S & Tabulator & "Bereit?"
S = S & Tabulator & "Name"
S = S & Tabulator & "System"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Nummer" & NeueZeile
' Trennlinie.
S = S & String(105, "-") & NeueZeile
For Each LW In LWs
S = S & LW.DriveLetter
S = S & Tabulator & LW.Path
S = S & Tabulator & ZeigeLWTyp(LW)
S = S & Tabulator & LW.IsReady
If LW.IsReady Then
If DriveTypeNetzwerk = LW.DriveType Then
S = S & Tabulator & LW.ShareName
Else
S = S & Tabulator & LW.VolumeName
End If
S = S & Tabulator & LW.FileSystem
S = S & Tabulator & LW.TotalSize
S = S & Tabulator & LW.FreeSpace
S = S & Tabulator & LW.AvailableSpace
S = S & Tabulator & Hex(LW.SerialNumber)
End If
S = S & NeueZeile
Next
ErzeugeLWInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeDateiInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status einer Datei beschreibt.
'
' Zeigt Folgendes
'
' - File.Path
' - File.Name
' - File.Type
' - File.DateCreated
' - File.DateLastAccessed
' - File.DateLastModified
' - File.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeDateiInformation(Datei)
Dim S
S = NeueZeile & "Pfad:" & Tabulator & Datei.Path
S = S & NeueZeile & "Name:" & Tabulator & Datei.Name
S = S & NeueZeile & "Typ:" & Tabulator & Datei.Type
S = S & NeueZeile & "Attribute:" & Tabulator & ZeigeDateiAttribute(Datei)
S = S & NeueZeile & "Erstellt:" & Tabulator & Datei.DateCreated
S = S & NeueZeile & "Letzter Zugriff:" & Tabulator & Datei.DateLastAccessed
S = S & NeueZeile & "Letzte Änderung:" & Tabulator & Datei.DateLastModified
S = S & NeueZeile & "Größe" & Tabulator & Datei.Size & NeueZeile
ErzeugeDateiInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeOrdnerInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status eines Ordners beschreibt.
'
' Zeigt Folgendes
'
' - Folder.Path
' - Folder.Name
' - Folder.DateCreated
' - Folder.DateLastAccessed
' - Folder.DateLastModified
' - Folder.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeOrdnerInformation(Ordner)
Dim S
S = "Pfad:" & Tabulator & Ordner.Path
S = S & NeueZeile & "Name:" & Tabulator & Ordner.Name
S = S & NeueZeile & "Attribute:" & Tabulator & ZeigeDateiAttribute(Ordner)
S = S & NeueZeile & "Erstellt:" & Tabulator & Ordner.DateCreated
S = S & NeueZeile & "Letzter Zugriff:" & Tabulator & Ordner.DateLastAccessed
S = S & NeueZeile & "Letzte Änderung:" & Tabulator & Ordner.DateLastModified
S = S & NeueZeile & "Größe:" & Tabulator & Ordner.Size & NeueZeile
ErzeugeOrdnerInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeAlleOrdnerInformationen
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status eines Ordners
' und all seiner Dateien und untergeordneten Ordner beschreibt.
'
' Zeigt Folgendes
'
' - Folder.Path
' - Folder.SubFolders
' - Folders.Count
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeAlleOrdnerInformationen(Ordner)
Dim S
Dim UnterOrdnerAuflistung
Dim UnterOrdner
Dim Dateien
Dim Datei
S = "Ordner:" & Tabulator & Ordner.Path & NeueZeile & NeueZeile
Set Dateien = Ordner.Files
If 1 = Dateien.Count Then
S = S & "Es ist 1 Datei vorhanden" & NeueZeile
Else
S = S & "Es sind " & Dateien.Count & "Dateien vorhanden" & NeueZeile
End If
If Dateien.Count <> 0 Then
For Each Datei In Dateien
S = S & ErzeugeDateiInformation(Datei)
Next
End If
Set UnterOrdnerAuflistung = Ordner.SubFolders
If 1 = UnterOrdnerAuflistung.Count Then
S = S & NeueZeile & "Es ist 1 Unterordner vorhanden" & NeueZeile & NeueZeile
Else
S = S & NeueZeile & "Es sind" & UnterOrdnerAuflistung.Count & "Unterordner vorhanden" & NeueZeile & NeueZeile
End If
If UnterOrdnerAuflistung.Count <> 0 Then
For Each UnterOrdner In UnterOrdnerAuflistung
S = S & ErzeugeOrdnerInformation(UnterOrdner)
Next
S = S & NeueZeile
For Each UnterOrdner In UnterOrdnerAuflistung
S = S & ErzeugeAlleOrdnerInformationen(UnterOrdner)
Next
End If
ErzeugeAlleOrdnerInformationen = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeTestInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status des Ordners C:\Test
' und all seiner Dateien und untergeordneten Ordner beschreibt.
'
' Zeigt Folgendes
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.GetFolder
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeTestInformation(FSO)
Dim TestOrdner
Dim S
If Not FSO.DriveExists(TestLW) Then Exit Function
If Not FSO.FolderExists(TestDateiPfad) Then Exit Function
Set TestOrdner = FSO.GetFolder(TestDateiPfad)
ErzeugeTestInformation = ErzeugeAlleOrdnerInformationen(TestOrdner)
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' LoescheTestVerzeichnis
'
' Zweck:
'
' Bereinigt das Testverzeichnis.
'
' Zeigt Folgendes
'
' - FileSystemObject.GetFolder
' - FileSystemObject.DeleteFile
' - FileSystemObject.DeleteFolder
' - Folder.Delete
' - File.Delete
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub LoescheTestVerzeichnis(FSO)
Dim TestOrdner
Dim UnterOrdner
Dim Datei
' Zwei Möglichkeiten, eine Datei zu löschen:
FSO.DeleteFile(TestDateiPfad & "\Beatles\OctopusGarden.txt")
Set Datei = FSO.GetFile(TestDateiPfad & "\Beatles\BathroomWindow.txt")
Datei.Delete
' Zwei Möglichkeiten, einen Ordner zu löschen:
FSO.DeleteFolder(TestDateiPfad & "\Beatles")
FSO.DeleteFile(TestDateiPfad & "\Liesmich.txt")
Set TestOrdner = FSO.GetFolder(TestDateiPfad)
TestOrdner.Delete
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeLiedText
'
' Zweck:
'
' Erstellt mehrere Textdateien in einem Ordner.
'
'
' Zeigt Folgendes
'
' - FileSystemObject.CreateTextFile
' - TextStream.writeLine
' - TextStream.write
' - TextStream.writeBlankLines
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ErzeugeLiedText(Ordner)
Dim TextStream
Set TextStream = Ordner.CreateTextFile("OctopusGarden.txt")
TextStream.write("Octopus' Garden") ' Beachten Sie, dass der Datei kein Zeilenvorschub hinzugefügt wird.
TextStream.WriteLine("(von Ringo Starr)")
TextStream.writeBlankLines(1)
TextStream.writeLine("I'd like to be under the sea, in an octopus' garden in the shade,")
TextStream.writeLine("He'd let us in, knows where we've been - in his octopus' garden in the shade.")
TextStream.writeBlankLines(2)
TextStream.Close
Set TextStream = Ordner.CreateTextFile("BathroomWindow.txt")
TextStream.writeLine("She Came In Through The Bathroom Window (von Lennon/McCartney)")
TextStream.writeLine("")
TextStream.writeLine("She came in through the bathroom window, protected by a silver spoon")
TextStream.writeLine("But now she sucks her thumb and wanders by the banks of her own lagoon")
TextStream.writeBlankLines(2)
TextStream.Close
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' HoleLiedText
'
' Zweck:
'
' Zeigt den Inhalt der Liedtexte an.
'
'
' Zeigt Folgendes
'
' - FileSystemObject.OpenTextFile
' - FileSystemObject.GetFile
' - TextStream.ReadAll
' - TextStream.Close
' - File.OpenAsTextStream
' - TextStream.AtEndOfStream
' - TextStream.ReadLine
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function HoleLiedText(FSO)
Dim TextStream
Dim S
Dim Datei
' Es gibt verschiedene Möglichkeiten, eine Textdatei zu öffnen und die
' Daten dieser Datei zu lesen. Hier sind zwei Möglichkeiten:
Set TextStream = FSO.OpenTextFile(TestDateiPfad & "\Beatles\OctopusGarden.txt", DateiOeffnenZumLesen)
S = TextStream.ReadAll & NeueZeile & NeueZeile
TextStream.Close
Set Datei = FSO.GetFile(TestDateiPfad & "\Beatles\BathroomWindow.txt")
Set TextStream = Datei.OpenAsTextStream(DateiOeffnenZumLesen)
Do While Not TextStream.AtEndOfStream
S = S & TextStream.ReadLine & NeueZeile
Loop
TextStream.Close
HoleLiedText = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeTestVerzeichnis
'
' Zweck:
'
' Erstellt eine Verzeichnishierarchie, um das FileSystemObject-Objekt zu beschreiben.
'
' Die Hierarchie wird in dieser Reihenfolge erstellt:
'
' C:\Test
' C:\Test\Liesmich.txt
' C:\Test\Beatles
' C:\Test\Beatles\OctopusGarden.txt
' C:\Test\Beatles\BathroomWindow.txt
'
'
' Zeigt Folgendes
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.CreateFolder
' - FileSystemObject.CreateTextFile
' - Folders.Add
' - Folder.CreateTextFile
' - TextStream.writeLine
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeTestVerzeichnis(FSO)
Dim TestOrdner
Dim UnterOrdnerAuflistung
Dim UnterOrdner
Dim TextStream
' Bricht ab, wenn (a) das Laufwerk nicht vorhanden oder (b) das zu erstellende Verzeichnis bereits
' vorhanden ist.
If Not FSO.DriveExists(TestLW) Then
ErzeugeTestVerzeichnis = False
Exit Function
End If
If FSO.FolderExists(TestDateiPfad) Then
ErzeugeTestVerzeichnis = False
Exit Function
End If
Set TestOrdner = FSO.CreateFolder(TestDateiPfad)
Set TextStream = FSO.CreateTextFile(TestDateiPfad & "\Liesmich.txt")
TextStream.writeLine("Meine Liedtextsammlung")
TextStream.Close
Set UnterOrdnerAuflistung = TestOrdner.SubFolders
Set UnterOrdner = UnterOrdnerAuflistung.Add("Beatles")
ErzeugeLiedText UnterOrdner
ErzeugeTestVerzeichnis = True
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Die Hauptroutine
'
' Zunächst wird ein Testverzeichnis mit einigen Unterordnern und Dateien erstellt.
' Anschließend werden Informationen über die verfügbaren Festplattenlaufwerke und
' über das Testverzeichnis ausgegeben und danach alles wieder entfernt.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Main
Dim FSO
' Einrichten globaler Daten.
Tabulator = Chr(9)
NeueZeile = Chr(10)
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not ErzeugeTestVerzeichnis(FSO) Then
Ausgabe "Testverzeichnis ist bereits vorhanden oder kann nicht erstellt werden. Fortsetzung nicht möglich."
Exit Sub
End If
Ausgabe ErzeugeLWInformation(FSO) & NeueZeile & NeueZeile
Ausgabe ErzeugeTestInformation(FSO) & NeueZeile & NeueZeile
Ausgabe HoleLiedText(FSO) & NeueZeile & NeueZeile
LoescheTestVerzeichnis(FSO)
End Sub
#########################################################################
>>> gmxautologin.vbs <<<
'v3.8***************************************************
' File: GmxAutologin.vbs
' Autor: ??? - PC-Welt 09/2003
' dieseyer.de
'
' Lädt im IE eine Site und übernimmt das Login.
'*******************************************************
Option Explicit
Dim Kennung, Passwort, EMailSite, Text
Dim MeinIE, READYSTATE_COMPLETE
Dim oDoc, oArea, oRng
EMailSite = "http://www.gmx.net"
Kennung = "username@gmx.de"
Passwort = "geheim"
Passwort = ""
If Passwort = "" then
Text = "Mit welchem Passwort soll der Account " & vbCRLF
Text = Text & vbTab & UCase(Kennung) & vbCRLF
Text = Text & "bei " & EMailSite & " geöffnet werden?"
If Passwort = "" then Passwort = InputBox (Text, WScript.ScriptName)
If Passwort = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Passwort = "" then WScript.Quit
End If
READYSTATE_COMPLETE = 4
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
Loop
Set oDoc = MeinIE.Document
oDoc.all.id.value = Kennung
oDoc.all.p.value = Passwort
oDoc.all.login.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
WScript.Quit
' Zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' IE: <input type="text" name="id" size="10" class="i10">
' VBS: oDoc.all.id.value = Kennung
' Funktion: Durch das VBS-Skript soll das Input-Feld für den Anmeldenamen
' (als 'Kennung' auf der HTML-Seite zu lesen) hat den (Variablen-)
' Namen 'id' (im HTML-Code) und soll den Inhalt (value; Wert)
' erhalten, der in der (Skript-) Variablen 'Kennung' steht.
' IE: <input type="password" name="p" size="10" class="i10">
' VBS: oDoc.all.p.value
' Funktion: Durch das VBScript-Skript soll das Input-Feld für das Passwort
' (als 'Passwort' auf der HTML-Seite zu lesen) hat den (Variablen-)
' Namen 'p' und soll den Inhalt (value; Wert) erhalten, der in der
' (Skript-) Variablen 'Passwort' steht.
' VBS: oDoc.all.login.Submit
' Funktion: werden die nunmehr getätigten Eingabe an das HTML-Formular übergeben
' (entspricht einem <Enter> bzw. einem Klick auf 'Login') und an den
' Server (bei gmx.net) gesendet.
#########################################################################
>>> gmxautologin2.vbs <<<
'v3.9**************************************************
' File: GmxAutologin2.vbs
' Autor: Raoul A.
' madraoul1@yahoo.de
' Lädt im IE eine Site und übernimmt das Login.
' Neue Funktion: Speichert Username und Kennwort
'******************************************************
Option Explicit
Dim Kennung, Passwort, EMailSite, Text ,Text2, Text3
Dim MeinIE, READYSTATE_COMPLETE
Dim oDoc, oArea, oRng
Dim FSO,f,TextStream, output, Dialog, raoul
Dim f1, create, output2, dialog2
Text = "Bitte Passwort eingaben! "
Text2 = "Bitte username eingeben!"
Text3 = "Bitte Email-Internetadresse eingeben!"
EMailSite = "www.gmx.de"
Kennung = ""
Passwort = ""
dialog = ""
Set FSO = CreateObject("Scripting.FileSystemObject")
f1 = ("C:\daten.txt")
if not FSO.FileExists(f1) then
set create = FSO.CreateTextFile("C:\daten.txt")
dialog = InputBox (Text2, WScript.ScriptName)
If dialog = "" then
WScript.echo "es wurde nichts eingegeben"
WScript.quit
End if
create.writeline(dialog)
dialog2 = InputBox (Text, WScript.ScriptName)
If dialog2 = "" then
WScript.echo "es wurde nichts eingegeben"
WScript.quit
End If
create.writeLine(dialog2)
create.Close
END if
Set TextStream = FSO.OpenTextFile("C:\daten.txt")
IF Kennung = "" then
output = TextStream.ReadLine()
Kennung = output
WScript.Echo "Username:"& Kennung
End if
Set raoul = FSO.OpenTextFile("C:\daten.txt")
IF Passwort = "" then
output2 = raoul.SkipLine() & raoul.ReadLine()
Passwort = output2
WScript.Echo "Passwort:"& Passwort
End if
READYSTATE_COMPLETE = 4
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
Loop
Set oDoc = MeinIE.Document
oDoc.all.id.value = Kennung
oDoc.all.p.value = Passwort
oDoc.all.login.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
#########################################################################
>>> listservices.vbs <<<
'==========================================================================
'
' AUTHOR: Janke , DTC
' DATE : 08.11.2002
'
' COMMENT: Listet alle Services eines Rechners
'
' (Leicht angepasst von dieseyer@gmx.de; v3.9.)
'==========================================================================
Computername = WScript.CreateObject("WScript.Network").ComputerName
ComputerName = InputBox("Für welchen Rechner?", WScript.ScriptName, ComputerName )
If ComputerName = "" then WScript.Quit
winmgmt1 = "winmgmts:{impersonationLevel=impersonate}!//" & ComputerName
Set ServSet = GetObject( winmgmt1 ).InstancesOf("Win32_service")
LogDatei now()
LogDatei ComputerName & " - Liste aller laufenden Services: "
for each Serv in ServSet
GetObject("winmgmts:").InstancesOf ("win32_service")
Text = Serv.Description & vbCRLF
Text = Text & vbTab & " Executable: " & Serv.PathName & vbCRLF
Text = Text & vbTab & " Status: " & Serv.Status & vbCRLF
Text = Text & vbTab & " State: " & Serv.State & vbCRLF
Text = Text & vbTab & " Start Mode: " & Serv.StartMode & vbCRLF
Text = Text & vbTab & " Start Name: " & Serv.StartName & vbCRLF
LogDatei Text
' MsgBox Text, , WScript.ScriptName
next
LogDatei now()
LogDateiAnzeige
WScript.Quit
'*********************************
Sub LogDatei (LogTxt) ' v3.9
'*********************************
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(WScript.ScriptName & ".log", 8, true).WriteLine (LogTxt)
End Sub ' LogDatei
'*********************************
Sub LogDateiAnzeige ' v3.9
'*********************************
WScript.CreateObject("WScript.Shell").run "notepad " & WScript.ScriptName & ".log"
End Sub ' LogDatei
#########################################################################
>>> datensicherung.vbs <<<
'v3.6********************************************************
' File: Datensicherung.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Gemäß der Verzeichnisliste "Datensicherung.txt" wird auf
' dem ZielLaufwerk (1. zeile in "Datensicherung.txt") eine
' komprimierte Datei (Verzeichnis) mit dem Tagesdatum
' erstellt, in der alle Dateien der Verzeichnisse mit
' Unterverzeichnissen, wie in "Datensicherung.txt" gelistet,
' enthalten sind.
' Zeilen, die mit einem Leerschrit, einem Semikolon oder
' einem Apostroph beginnen werden ignoriert.
'************************************************************
Option Explicit
Dim fso, WSHShell, WSHNetzWerk, WSHLaufWerk, oArgs
Dim i, FileOut, FileOut1, FileIn, TXT, TXT1, Text, ZielOK, VerzOK, Problem, Menge, Pwd
Dim Zeit, ZielVerz, VerzListe, VerzNr
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' Set WSHNetzWerk = WScript.CreateObject("WScript.NetWork")
' Set WSHLaufWerk = WSHNetzWerk.EnumNetworkDrives()
set oArgs = Wscript.Arguments
Pwd = ""
' Passwort definieren
' => nächste Zeile frei geben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PwdAbfrage ' Function Aufruf
LogDatei ( vbCRLF & now() & " - " & UCase(WScript.ScriptName) & " gestartet"& vbCRLF & "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ " )
' Prüfen, ob VerzListe-Datei existiert;
' wenn nicht: anlegen und ausfüllen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' VerzListe = "Datensicherung.txt"
VerzListe = fso.GetBaseName( WScript.ScriptName ) & ".txt"
if not fso.FileExists( VerzListe ) then
Set FileOut = fso.OpenTextFile( VerzListe, 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( WScript.ScriptName, 1, true) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = "'" then Exit Do
FileOut.WriteLine( TXT )
Loop
FileOut.WriteLine( "' Bitte jetzt vervollständigen:" )
FileOut.WriteLine( "' 1. freie Zeile: Ziel-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' 2. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' ?. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.run VerzListe, 4, True
End If
' Prüfen, ob VerzListe korrekt ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - ermittelt das Zielverzeichnis der Datensicherungen
' - Datensicherung.tmp enthält Liste der zu sichernden Verzichnisse
ParameterAbfrage ' Function Aufruf
' Im Zielverzeichnis wird DatumVerzeichnis mit lfd. Nr. erzeugt
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = Datumverzeichnis ( ZielVerz ) ' Function Aufruf
Set FileIn = fso.OpenTextFile( fso.GetBaseName( VerzListe ) & ".tmp", 1, true) ' Datei zum Lesen öffnen
Menge = 0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = CStr( FileIn.Readline ) ' eine Zeile lesen
if Len( TXT ) < 8 Then Text = TXT & vbTab
if not Len( TXT ) < 8 Then Text = TXT
if not fso.FolderExists( TXT ) then
LogDatei ( vbCRLF & "!!! " & TXT & " nicht vorhanden. ")
Else
Menge = Menge + CLng(fso.GetFolder( TXT ).size)
Text = Text & vbTab & FormatNumber( fso.GetFolder( TXT ).size/1024 , 1) & " kByte" & vbTab & " zu sichern"
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).VolumeName
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).ShareName
LogDatei ( Text )
Text = Replace( Left ( TXT, 1) & "" & Mid ( TXT, 3) , "\" , "²")
'_______________________________________________________________
'Für die Verwendung von XCOPY folgende beiden Zeilen frei geben
' Text = "xcopy """ & TXT & "\*.*"" """ & ZielVerz & "\" & Text & "\*.*"" /S/E/V "
'_______________________________________________________________
'Für die Verwendung von ROBOCOPY folgende Zeile frei geben
' Text = "robocopy """ & TXT & """ """ & ZielVerz & "\" & Text & """ /S /E /sec /w:1 /r:1 /log:" & ZielVerz & "\" & Text & ".log "
'_______________________________________________________________
'Für die Verwendung von RAR zwei Zeilen frei geben
If Pwd = "" Then Text = "rar.exe a -ad -m5 -ap" & " -sfx """ & ZielVerz & "\" & Text & """ """ & TXT & """"
If not Pwd = "" Then Text = "rar.exe a -ad -m5 -ap -hp" & Pwd & " -sfx """ & ZielVerz & "\" & Text & """.rar """ & TXT & """"
' If Pwd = "" Then Text = "rar.exe a -ad -m5 -ap" & " """ & ZielVerz & "\" & Text & """ """ & TXT & """"
' If not Pwd = "" Then Text = "rar.exe a -ad -m5 -ap -hp" & Pwd & " """ & ZielVerz & "\" & Text & """.rar """ & TXT & """"
'_______________________________________________________________
'Wahlweise die RunBat oder WSHShell.Run Zeile frei geben
'msgbox text
' RunBat ( Text ) ' Function Aufruf
WSHShell.run Text , 4, True
' Passwort für LogDatei entfernen
Text = Replace( Text, Pwd, "~-_Pwd_-~" )
LogDatei Text & vbTab & " . . . abgeschlossen. " & vbCRLF
End If
Loop
LogDatei ( now() & " - " & UCase(WScript.ScriptName) & " beendet" )
LogDatei ( FormatNumber( Menge/1024, 1) & " kByte wurden in " & FormatNumber( fso.GetFolder( ZielVerz ).size/1024 , 1) & " kByte gepackt und nach " & ZielVerz & " gesichert. ")
Set FileIn = nothing
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' LogDatei anzeigen (und an das Ende springen)
' => nächste Zeile frei geben
' LogDateiAnzeige
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Erstelltes Zielverzeichnis mit gesicherten Daten anzeigen
' => nächste Zeile frei geben
WSHShell.run ZielVerz, 1
WScript.Quit
'---------------------------------------------------------
Function ParameterAbfrage
'---------------------------------------------------------
' VerzeichnisListe zeilenweise lesen und prüfen
i = 0
Problem = ""
ZielOK = ""
VerzOK = ""
VerzNr = 0
Text = ""
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1, true) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
' Bemerkungszeilen nicht prüfen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
ZielOK = "ok"
i = i + Len(TXT) +2
If not fso.FolderExists( TXT ) Then
ZielOK = "fehlt"
If VerzNr < 1 then FileOut.WriteLine( TXT )
If not VerzNr < 1 then FileOut.WriteLine( ";###" & ZielOk & " " & TXT )
Problem = "ja"
Else
FileOut.WriteLine( TXT )
End If
' Zeilen für MsgBox in Text sammeln; erste Zeile enthält ZielVerzeichnis
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Text = "" Then
ZielVerz = TXT
VerzOK = ZielOK
Text = "Nach " & ZielVerz & " (" & ZielOK & ") werden folgende Verzeichnisse gesichert (kopiert): " & vbTab & vbCRLF
' Zeilen für MsgBox in Text sammeln; jede weitere Zeile enthält zu sichernde Verzeichnisse
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Else
VerzNr = VerzNr +1
if i < 400 then
Text = Text & vbCRLF & VerzNr & vbTab & ZielOK & vbTab & " " & TXT
End If
End If
Else
FileOut.WriteLine( TXT )
End If
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
Text = Text & vbCRLF & " " & VerzNr & " Verzeichnisse insgesamt."
' Problem = "nEIn"
If UCase( left(Problem,2) ) = "JA" Then
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sollten angepasst werden, da nicht alle Verzeichnisse " & vbCRLF & "vorhanden sind."
Else
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sind soweit ok, können aber angepasst werden."
End If
If not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
Text = Text & vbCRLF & vbCRLF & UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
End If
Text = Text & vbCRLF & vbCRLF & "Parameter korrigieren oder Skript abbrechen? [No] in 10sec."
TXT = WshShell.Popup(Text, 15, WScript.ScriptName, 3+32)
If TXT = -1 AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
' wenn keine Taste gedrückt wurde
Text = UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
Text = Text & vbCRLF & vbCRLF & UCase("Das Skript wird ohne Datensicherung beendet!")
LogDatei ( Text ) ' Sub Aufruf
WshShell.Popup Text, 10, WScript.ScriptName, 64
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
If TXT = vbNo AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
MsgBox UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!"), 64, WScript.ScriptName
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbYes then
fso.CopyFile fso.GetBaseName( VerzListe) & ".tmp", VerzListe
WSHShell.run VerzListe, , True
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbCancel then
WshShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName, 64
Text = UCase("Das Skript wurde abgebrochen = keine Datensicherung!")
LogDatei ( Text ) ' Sub Aufruf
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
i = 0
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1, true) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
If i > 0 then FileOut.WriteLine( TXT )
i = i +1
End If
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
End Function ' ParameterAbfrage
'---------------------------------------------------------
Function Datumverzeichnis ( ZielVerz )
'---------------------------------------------------------
' legt im ZielVerzeichhnis ein Datumverzeichnis mit lfd.
' Nummer an: (k:\siceherer\)02-12-03_0
Zeit = now()
' zweistellige Jahreszahl
Datumverzeichnis = Right(Year(Zeit),2)
' zweistellige Monatszahl
If Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Month(Zeit)
If not Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Month(Zeit)
' zweistellige Tageszahl
If Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Day(Zeit)
If not Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Day(Zeit)
' zweistellige Stundezahl
' If Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_0" & Hour(Zeit)
' If not Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_" & Hour(Zeit)
' zweistellige Minutenzahl
' If Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' If not Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' zweistellige Sekundenzahl
' If Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Second(Zeit)
' If not Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'" & Second(Zeit)
' if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis ) then
' fso.CreateFolder( ZielVerz & "\" & Datumverzeichnis )
' Exit Function
' End If
for i = 0 to 99
If i < 1 then i = "0"
If i < 10 then i = "0" & CStr(i) ' zweistellig machen
If not i < 10 then i = "" & CStr(i) ' zweistellig lassen
if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis & "." & i ) then
Datumverzeichnis = ZielVerz & "\" & Datumverzeichnis & "." & i
fso.CreateFolder( Datumverzeichnis )
Exit Function
End If
next
End Function ' Datumverzeichnis ( ZielVerz )
'---------------------------------------------------------
Function RunBat ( BatTXT )
'---------------------------------------------------------
' erzeugt eine .BAT Datei mit 2x Pause und führt diese aus
' MsgBox BatTXT
TXT1 = "bsp.bat"
Set FileOut1 = fso.OpenTextFile( TXT1 , 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
FileOut1.WriteLine( "@echo off")
FileOut1.WriteLine( "@echo " & BatTXT )
FileOut1.WriteLine( "@" & BatTXT )
FileOut1.WriteLine( "@pause")
FileOut1.WriteLine( "@pause")
FileOut1.Close
Set FileOut1 = nothing
WSHShell.run "%comspec% /c " & TXT1 , , True
End Function ' RunBat ( BatTXT )
'---------------------------------------------------------
Sub LogDatei (LogTxt)
'---------------------------------------------------------
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( fso.GetBaseName( WScript.ScriptName ) & ".log", 8, true)
' fileOut.WriteLine (vbCRLF & Now() )
fileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
'---------------------------------------------------------
Sub PwdAbfrage
'---------------------------------------------------------
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Pwd = oArgs.item(i)
Exit For ' ein Argument reicht
Next
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
' If not Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4+32)
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("nicht mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
If Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4+32)
Text = "Mit welchen Passwort sollen die Dateien der Datensicherung geschützt werden?"
Text = Text & vbCRLF & "Das Passwort darf ! KEINE ! Leerzeichen enthalten!"
If TXT = vbNo then Pwd = InputBox (Text, WScript.ScriptName)
End Sub ' PwdAbfrage
'---------------------------------------------------------
Sub LogDateiAnzeige
'---------------------------------------------------------
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
WSHShell.run "notepad " & fso.GetBaseName( WScript.ScriptName ) & ".log"
On Error Resume Next
WScript.Sleep 500
WSHShell.SendKeys "^{End}" ' ans Ende springen
WScript.Sleep 500
WSHShell.SendKeys "{Up}" ' eine Zeile hoch
WScript.Sleep 500
WSHShell.SendKeys "+{Down}" ' mit gedrückter Shift-Taste eine Zeile nach unten
' markiert die letzte Zeile
' WScript.Sleep 20000
' WSHShell.SendKeys "%{F4}" ' schließt das aktuelle Fenster
On Error GoTo 0
WScript.Quit
End Sub ' LogDateiAnzeige
#########################################################################
>>> datensicherung.vbs <<<
'v3.6********************************************************
' File: Datensicherung.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Gemäß der Verzeichnisliste "Datensicherung.txt" wird auf
' dem ZielLaufwerk (1. zeile in "Datensicherung.txt") eine
' komprimierte Datei (Verzeichnis) mit dem Tagesdatum
' erstellt, in der alle Dateien der Verzeichnisse mit
' Unterverzeichnissen, wie in "Datensicherung.txt" gelistet,
' enthalten sind.
' Zeilen, die mit einem Leerschrit, einem Semikolon oder
' einem Apostroph beginnen werden ignoriert.
'************************************************************
Option Explicit
Dim fso, WSHShell, WSHNetzWerk, WSHLaufWerk, oArgs
Dim i, FileOut, FileOut1, FileIn, TXT, TXT1, Text, ZielOK, VerzOK, Problem, Menge, Pwd
Dim Zeit, ZielVerz, VerzListe, VerzNr
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' Set WSHNetzWerk = WScript.CreateObject("WScript.NetWork")
' Set WSHLaufWerk = WSHNetzWerk.EnumNetworkDrives()
set oArgs = Wscript.Arguments
Pwd = ""
' Passwort definieren
' => nächste Zeile frei geben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PwdAbfrage ' Function Aufruf
LogDatei ( vbCRLF & now() & " - " & UCase(WScript.ScriptName) & " gestartet"& vbCRLF & "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ " )
' Prüfen, ob VerzListe-Datei existiert;
' wenn nicht: anlegen und ausfüllen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' VerzListe = "Datensicherung.txt"
VerzListe = fso.GetBaseName( WScript.ScriptName ) & ".txt"
if not fso.FileExists( VerzListe ) then
Set FileOut = fso.OpenTextFile( VerzListe, 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( WScript.ScriptName, 1, true) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = "'" then Exit Do
FileOut.WriteLine( TXT )
Loop
FileOut.WriteLine( "' Bitte jetzt vervollständigen:" )
FileOut.WriteLine( "' 1. freie Zeile: Ziel-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' 2. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' ?. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.run VerzListe, 4, True
End If
' Prüfen, ob VerzListe korrekt ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - ermittelt das Zielverzeichnis der Datensicherungen
' - Datensicherung.tmp enthält Liste der zu sichernden Verzichnisse
ParameterAbfrage ' Function Aufruf
' Im Zielverzeichnis wird DatumVerzeichnis mit lfd. Nr. erzeugt
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = Datumverzeichnis ( ZielVerz ) ' Function Aufruf
Set FileIn = fso.OpenTextFile( fso.GetBaseName( VerzListe ) & ".tmp", 1, true) ' Datei zum Lesen öffnen
Menge = 0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = CStr( FileIn.Readline ) ' eine Zeile lesen
if Len( TXT ) < 8 Then Text = TXT & vbTab
if not Len( TXT ) < 8 Then Text = TXT
if not fso.FolderExists( TXT ) then
LogDatei ( vbCRLF & "!!! " & TXT & " nicht vorhanden. ")
Else
Menge = Menge + CLng(fso.GetFolder( TXT ).size)
Text = Text & vbTab & FormatNumber( fso.GetFolder( TXT ).size/1024 , 1) & " kByte" & vbTab & " zu sichern"
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).VolumeName
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).ShareName
LogDatei ( Text )
Text = Replace( Left ( TXT, 1) & "" & Mid ( TXT, 3) , "\" , "²")
'_______________________________________________________________
'Für die Verwendung von XCOPY folgende beiden Zeilen frei geben
' Text = "xcopy """ & TXT & "\*.*"" """ & ZielVerz & "\" & Text & "\*.*"" /S/E/V "
'_______________________________________________________________
'Für die Verwendung von ROBOCOPY folgende Zeile frei geben
' Text = "robocopy """ & TXT & """ """ & ZielVerz & "\" & Text & """ /S /E /sec /w:1 /r:1 /log:" & ZielVerz & "\" & Text & ".log "
'_______________________________________________________________
'Für die Verwendung von RAR zwei Zeilen frei geben
If Pwd = "" Then Text = "rar.exe a -ad -m5 -ap" & " -sfx """ & ZielVerz & "\" & Text & """ """ & TXT & """"
If not Pwd = "" Then Text = "rar.exe a -ad -m5 -ap -hp" & Pwd & " -sfx """ & ZielVerz & "\" & Text & """.rar """ & TXT & """"
' If Pwd = "" Then Text = "rar.exe a -ad -m5 -ap" & " """ & ZielVerz & "\" & Text & """ """ & TXT & """"
' If not Pwd = "" Then Text = "rar.exe a -ad -m5 -ap -hp" & Pwd & " """ & ZielVerz & "\" & Text & """.rar """ & TXT & """"
'_______________________________________________________________
'Wahlweise die RunBat oder WSHShell.Run Zeile frei geben
'msgbox text
' RunBat ( Text ) ' Function Aufruf
WSHShell.run Text , 4, True
' Passwort für LogDatei entfernen
Text = Replace( Text, Pwd, "~-_Pwd_-~" )
LogDatei Text & vbTab & " . . . abgeschlossen. " & vbCRLF
End If
Loop
LogDatei ( now() & " - " & UCase(WScript.ScriptName) & " beendet" )
LogDatei ( FormatNumber( Menge/1024, 1) & " kByte wurden in " & FormatNumber( fso.GetFolder( ZielVerz ).size/1024 , 1) & " kByte gepackt und nach " & ZielVerz & " gesichert. ")
Set FileIn = nothing
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' LogDatei anzeigen (und an das Ende springen)
' => nächste Zeile frei geben
' LogDateiAnzeige
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Erstelltes Zielverzeichnis mit gesicherten Daten anzeigen
' => nächste Zeile frei geben
WSHShell.run ZielVerz, 1
WScript.Quit
'---------------------------------------------------------
Function ParameterAbfrage
'---------------------------------------------------------
' VerzeichnisListe zeilenweise lesen und prüfen
i = 0
Problem = ""
ZielOK = ""
VerzOK = ""
VerzNr = 0
Text = ""
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1, true) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
' Bemerkungszeilen nicht prüfen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
ZielOK = "ok"
i = i + Len(TXT) +2
If not fso.FolderExists( TXT ) Then
ZielOK = "fehlt"
If VerzNr < 1 then FileOut.WriteLine( TXT )
If not VerzNr < 1 then FileOut.WriteLine( ";###" & ZielOk & " " & TXT )
Problem = "ja"
Else
FileOut.WriteLine( TXT )
End If
' Zeilen für MsgBox in Text sammeln; erste Zeile enthält ZielVerzeichnis
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Text = "" Then
ZielVerz = TXT
VerzOK = ZielOK
Text = "Nach " & ZielVerz & " (" & ZielOK & ") werden folgende Verzeichnisse gesichert (kopiert): " & vbTab & vbCRLF
' Zeilen für MsgBox in Text sammeln; jede weitere Zeile enthält zu sichernde Verzeichnisse
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Else
VerzNr = VerzNr +1
if i < 400 then
Text = Text & vbCRLF & VerzNr & vbTab & ZielOK & vbTab & " " & TXT
End If
End If
Else
FileOut.WriteLine( TXT )
End If
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
Text = Text & vbCRLF & " " & VerzNr & " Verzeichnisse insgesamt."
' Problem = "nEIn"
If UCase( left(Problem,2) ) = "JA" Then
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sollten angepasst werden, da nicht alle Verzeichnisse " & vbCRLF & "vorhanden sind."
Else
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sind soweit ok, können aber angepasst werden."
End If
If not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
Text = Text & vbCRLF & vbCRLF & UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
End If
Text = Text & vbCRLF & vbCRLF & "Parameter korrigieren oder Skript abbrechen? [No] in 10sec."
TXT = WshShell.Popup(Text, 15, WScript.ScriptName, 3+32)
If TXT = -1 AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
' wenn keine Taste gedrückt wurde
Text = UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
Text = Text & vbCRLF & vbCRLF & UCase("Das Skript wird ohne Datensicherung beendet!")
LogDatei ( Text ) ' Sub Aufruf
WshShell.Popup Text, 10, WScript.ScriptName, 64
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
If TXT = vbNo AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
MsgBox UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!"), 64, WScript.ScriptName
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbYes then
fso.CopyFile fso.GetBaseName( VerzListe) & ".tmp", VerzListe
WSHShell.run VerzListe, , True
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbCancel then
WshShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName, 64
Text = UCase("Das Skript wurde abgebrochen = keine Datensicherung!")
LogDatei ( Text ) ' Sub Aufruf
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
i = 0
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1, true) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
If i > 0 then FileOut.WriteLine( TXT )
i = i +1
End If
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
End Function ' ParameterAbfrage
'---------------------------------------------------------
Function Datumverzeichnis ( ZielVerz )
'---------------------------------------------------------
' legt im ZielVerzeichhnis ein Datumverzeichnis mit lfd.
' Nummer an: (k:\siceherer\)02-12-03_0
Zeit = now()
' zweistellige Jahreszahl
Datumverzeichnis = Right(Year(Zeit),2)
' zweistellige Monatszahl
If Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Month(Zeit)
If not Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Month(Zeit)
' zweistellige Tageszahl
If Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Day(Zeit)
If not Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Day(Zeit)
' zweistellige Stundezahl
' If Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_0" & Hour(Zeit)
' If not Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_" & Hour(Zeit)
' zweistellige Minutenzahl
' If Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' If not Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' zweistellige Sekundenzahl
' If Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Second(Zeit)
' If not Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'" & Second(Zeit)
' if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis ) then
' fso.CreateFolder( ZielVerz & "\" & Datumverzeichnis )
' Exit Function
' End If
for i = 0 to 99
If i < 1 then i = "0"
If i < 10 then i = "0" & CStr(i) ' zweistellig machen
If not i < 10 then i = "" & CStr(i) ' zweistellig lassen
if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis & "." & i ) then
Datumverzeichnis = ZielVerz & "\" & Datumverzeichnis & "." & i
fso.CreateFolder( Datumverzeichnis )
Exit Function
End If
next
End Function ' Datumverzeichnis ( ZielVerz )
'---------------------------------------------------------
Function RunBat ( BatTXT )
'---------------------------------------------------------
' erzeugt eine .BAT Datei mit 2x Pause und führt diese aus
' MsgBox BatTXT
TXT1 = "bsp.bat"
Set FileOut1 = fso.OpenTextFile( TXT1 , 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
FileOut1.WriteLine( "@echo off")
FileOut1.WriteLine( "@echo " & BatTXT )
FileOut1.WriteLine( "@" & BatTXT )
FileOut1.WriteLine( "@pause")
FileOut1.WriteLine( "@pause")
FileOut1.Close
Set FileOut1 = nothing
WSHShell.run "%comspec% /c " & TXT1 , , True
End Function ' RunBat ( BatTXT )
'---------------------------------------------------------
Sub LogDatei (LogTxt)
'---------------------------------------------------------
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( fso.GetBaseName( WScript.ScriptName ) & ".log", 8, true)
' fileOut.WriteLine (vbCRLF & Now() )
fileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
'---------------------------------------------------------
Sub PwdAbfrage
'---------------------------------------------------------
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Pwd = oArgs.item(i)
Exit For ' ein Argument reicht
Next
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
' If not Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4+32)
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("nicht mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
If Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4+32)
Text = "Mit welchen Passwort sollen die Dateien der Datensicherung geschützt werden?"
Text = Text & vbCRLF & "Das Passwort darf ! KEINE ! Leerzeichen enthalten!"
If TXT = vbNo then Pwd = InputBox (Text, WScript.ScriptName)
End Sub ' PwdAbfrage
'---------------------------------------------------------
Sub LogDateiAnzeige
'---------------------------------------------------------
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
WSHShell.run "notepad " & fso.GetBaseName( WScript.ScriptName ) & ".log"
On Error Resume Next
WScript.Sleep 500
WSHShell.SendKeys "^{End}" ' ans Ende springen
WScript.Sleep 500
WSHShell.SendKeys "{Up}" ' eine Zeile hoch
WScript.Sleep 500
WSHShell.SendKeys "+{Down}" ' mit gedrückter Shift-Taste eine Zeile nach unten
' markiert die letzte Zeile
' WScript.Sleep 20000
' WSHShell.SendKeys "%{F4}" ' schließt das aktuelle Fenster
On Error GoTo 0
WScript.Quit
End Sub ' LogDateiAnzeige
#########################################################################
http://dieseyer.de • all rights reserved • © 2003 v3.B