http://dieseyer.de • all rights reserved • © 2011 v11.4
293 Skript-Dateien (*.vbs und *.hta) auf einen Blick:
#########################################################################
>>> 00-anfang-alle10s-trc32.vbs <<<
'*** v9.5 *** www.dieseyer.de ******************************
'
' Datei: 00-anfang-alle10s-trc32.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LetzteZeit, Tst
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( "-", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
WSHShell.Popup "= = = S T A R T = = =", 2, "031 :: " & WScript.ScriptName
Trace32Log "032 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "033 :: LogDatei: " & LogDatei, 1
Trace32Log "034 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "035 :: Angemeldeter User: " & WSHNet.UserName, 1
Do
Do ' Zeit "runden"
WScript.Sleep 200
Tst = now()
Tst = Mid( Tst, 1, Len( Tst ) - 1 ) ' für alle vollen 10s
' Tst = Mid( Tst, 1, Len( Tst ) - 2 ) ' für alle volle Minute
If Tst <> LetzteZeit Then LetzteZeit = Tst : Exit Do
Loop
Trace32Log "048 :: VBSmodTest: " & VBSmodTest & " - " & Tst, 1
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
If VBSmodTest > 10 Then Exit Do ' Ende nach 10 durchläufen
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "057 :: " & WScript.ScriptName
Trace32Log "058 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v?.? *** www.dieseyer.de ******************************
Function XXXX( YYYY, ZZZZ )
'***********************************************************
' On Error Resume Next
End Function ' XXXX( YYYY, ZZZZ )
'*** v5.A *** www.dieseyer.de ******************************
Sub VBSbeenden()
'***********************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "091 :: " & WScript.ScriptFullName & " existiert nicht!", 1
Trace32Log "092 :: " & WScript.ScriptFullName & " wird beendet . . . ", 1
Trace32Log "093 :: " & WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . ", 1
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "095 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de ******************************
Sub VBSneustart()
'***********************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "122 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "127 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "132 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 00-anfang-trc32.vbs <<<
'*** v?.? *** www.dieseyer.de ******************************
'
' Datei: AAAAA.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
' Call Trace32Log( "-", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
WSHShell.Popup "= = = S T A R T = = =", 2, "029 :: " & WScript.ScriptName
Trace32Log "030 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "031 :: LogDatei: " & LogDatei, 1
Trace32Log "032 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "033 :: Angemeldeter User: " & WSHNet.UserName, 1
Do
WScript.Sleep 1000 ' neue Sekunde abwarten
Do ' warten, bis eine neue Minute (mit xx:yy:00) anfängt
WScript.Sleep 20
If InStr( now(), ":00" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":10" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":20" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":30" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":40" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":50" ) = Len( now() ) - 2 Then Exit Do
Loop
Trace32Log "049 :: VBSmodTest: " & VBSmodTest, 1
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
If VBSmodTest > 10 Then Exit Do
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "056 :: " & WScript.ScriptName
Trace32Log "057 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v?.? *** www.dieseyer.de ******************************
Function XXXX( YYYY, ZZZZ )
'***********************************************************
' On Error Resume Next
End Function ' XXXX( YYYY, ZZZZ )
'*** v5.A *** www.dieseyer.de ******************************
Sub VBSbeenden()
'***********************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "090 :: " & WScript.ScriptFullName & " existiert nicht!", 1
Trace32Log "091 :: " & WScript.ScriptFullName & " wird beendet . . . ", 1
Trace32Log "092 :: " & WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . ", 1
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "094 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de ******************************
Sub VBSneustart()
'***********************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "121 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "126 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "131 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 00-anfang.vbs <<<
'*** v?.? *** www.dieseyer.de ******************************
'
' Datei: AAAAA.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest, VBSmodZahl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( "", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
WSHShell.Popup "= = = S T A R T = = =", 2, "028 :: " & WScript.ScriptName
Trace32Log "029 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "030 :: LogDatei: " & LogDatei, 1
Trace32Log "031 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "032 :: Angemeldeter User: " & WSHNet.UserName, 1
For i = 0 to Args.Count - 1 ' hole alle Argumente
Trace32Log "035 :: Argument " & i & ": >" & Args( i ) & "<", 1
Next
Do
WScript.Sleep 1000 ' neue Sekunde abwarten
Do ' warten, bis eine neue Minute (mit xx:yy:00) anfängt
WScript.Sleep 33 * VBSmodTest
If InStr( now(), ":00" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":10" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":20" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":30" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":40" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":50" ) = Len( now() ) - 2 Then Exit Do
Loop
Trace32Log "051 :: VBSmodTest: " & VBSmodTest, 1
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
If VBSmodTest > 10 Then Exit Do
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "058 :: " & WScript.ScriptName
Trace32Log "059 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v?.? *** www.dieseyer.de ******************************
Function XXXX( YYYY, ZZZZ )
'***********************************************************
' On Error Resume Next
End Function ' XXXX( YYYY, ZZZZ )
'*** v5.A *** www.dieseyer.de ******************************
Sub VBSbeenden()
'***********************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log( "092 :: " & WScript.ScriptFullName & " existiert nicht!" ), 1
Trace32Log( "093 :: " & WScript.ScriptFullName & " wird beendet . . . " ), 1
Trace32Log( "094 :: " & WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " ), 1
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "096 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de ******************************
Sub VBSneustart()
'***********************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "123 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "128 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "133 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v8.3 *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
Dim LogDateiX
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable LogDatei nicht außerhalb der Prozedur definiert
If Err.Number <> 0 Then LogDateiX = WScript.ScriptFullName & ".log"
On Error Goto 0
If LogTxt = "" Then ' eine neue .LOG-Datei wird erstellt, eine vorhandene überschrieben
Set FileOut = fso.OpenTextFile( LogDateiX, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDateiX, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Timer() & " " & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "256 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "257 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 100prozent.vbs <<<
'v4.3********************************************************
' File: 100prozent.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' "Erzeugt" 100% CPU-Last, bis es die Datei "ende.txt"
' gibt - das Skript sollte sich nicht auf einem Netz-
' laufwerk befinden.
'************************************************************
Option Explicit
Dim fso, i, n
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
MsgBox "Sobald es in dem Verzeichnis, in dem sich dieses Skript befindet," &vbCRLF & "die Datei ""ende.txt"" gibt, hört das Skript auf.", , WScript.ScriptName
i = 0
Do
i = i + 1
if i = 256*256*2 then n=1 ' : MsgBox i
if i > 256*256*2+256*4 then n=0 : i = 0 ' : MsgBox i
WScript.Sleep n
If fso.FileExists( "ende.txt" ) then Exit Do
Loop
MsgBox "Das waren wohl 100% CPU-Auslastung, oder?!", , WScript.ScriptName
#########################################################################
>>> 10ms.vbs <<<
'v5.A*****************************************************
Set Fso = WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss = WScript.CreateObject ( "WScript.Shell" )
Set Fso = WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss = WScript.CreateObject ( "WScript.Shell" )
' File: 10ms.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt die Zeit auf hundertstel Sekunden genau.
'
'***************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim ms : ms = ",00" & " Timer = " & Timer
If InStr( Timer, "," ) > 0 Then
' wenn Timer keine Nachkommastellen enthält
ms = Mid( Timer, InStr( Timer, "," ) ) & " Timer = " & Timer
End If
MsgBox "Jetzt ist es : " & Now() & ms, , "19 :: " & WScript.ScriptName
' alles in einer Zeile:
ms = now() : If InStr( Timer, "," ) > 0 Then ms = now() & Mid( Timer, InStr( Timer, "," ) )
MsgBox ms, , "24 :: " & WScript.ScriptName
#########################################################################
>>> 120minreboot.hta <<<
<head>
<!--
'v5.C***************************************************
' File: 120minReboot.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'*******************************************************
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SHOWINTASKBAR="no"
NAVIGABLE="no"
BORDER="none"
-->
<title>120minReboot</title>
<HTA:APPLICATION ID="oHTA"
SCROLL="No"
SHOWINTASKBAR="yes"
APPLICATIONNAME="120minReboot.hta"
>
<style type="text/css">
<!--
html, body { font-size:10pt; color:#E0C000; font-family:Verdana; font-weight:bold;
background:#1d2160;
}
a { font-size:100%; color:#FFFFFF; text-decoration:underline; }
a:active { color:red; }
a:link { color:#FFE000; }
a:visited { color:#E0C000; }
a:hover { color:red; }
a:active { color:#E0C000; }
-->
</style>
</head>
<script language="VBscript">
Const Dauer = "2:0:0"
Dim EndeZeit
'*******************************************************
Function ZeitAnzeige()
'*******************************************************
RestZeit = CDate( EndeZeit - Now() )
If Len( Hour( RestZeit ) ) = 1 Then Text = Text & "0"
Text = Text & Hour( RestZeit ) & ":"
If Len( Minute( RestZeit ) ) = 1 Then Text = Text & "0"
Text = Text & Minute( RestZeit ) & ":"
If Len( Second( RestZeit ) ) = 1 Then Text = Text & "0"
Text = Text & Second( RestZeit )
If CDate( EndeZeit ) > CDate( Now() ) Then Text = "==>> In " & Text & " startet dieser PC automatisch neu. <<=="
If not CDate( EndeZeit ) > CDate( Now() ) Then window.clearInterval( YesIntervall ) : self.close
document.all.RestZeitAnzeige.innerHTML = Text ' & "<br>" & EndeZeit
End Function ' ZeitAnzeige()
'*******************************************************
Function BeimLaden() ' ruft einige Routinen auf
'*******************************************************
call HTASize
EndeZeit = CDate( Now() + CDate( Dauer ) )
Call ZeitAnzeige
YesIntervall = window.setInterval( "ZeitAnzeige",1000 )
End Function ' BeimLaden
'*******************************************************
Sub HTASize()
'*******************************************************
' window.moveto Links, Oben
window.moveto 0, 0
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 640, 400
End Sub
'*******************************************************
Sub Auswahl()
'*******************************************************
' Call remoteShutdown( "" )
self.close
End Sub ' Auswahl()
'*******************************************************
Sub remoteShutdown( remotename ) ' 5.2 - http://dieseyer.de
'*******************************************************
' http://groups.google.de/groups?hl=de&lr=&newwindow=1&frame=right&th=43c55ccb528dbbc3&seekm=ebO58v50DHA.2480%40TK2MSFTNGP10.phx.gbl#link5
If remotename = "" Then remotename = CreateObject("WScript.Network").ComputerName
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
Dim wmi : Set wmi = GetObject( "winmgmts:{(RemoteShutdown)}!//" & remotename & "/root/cimv2" )
Dim objset : set objset = wmi.instancesof("win32_operatingsystem")
Dim obj, os
for each obj in objset
obj.security_.privileges.add 18, true
set os = obj : exit for
next
os.win32shutdown 6
End Sub ' remoteShutdown(remotename) 5.2 - http://dieseyer.de
</script>
<body onLoad="BeimLaden()" >
<center style="font-size:20pt; color:#E0C000; font-family:Verdana; font-weight:bold;">
Software Labor
</center>
<br>
Sehr geehrter Anwender,
<span style="font-size:4pt; "> <br> <br> </span>
nach dem die Installation der Software auf Ihren PC abgeschlossen ist,
sollte dieser PC neu gestartet werden.
<span style="font-size:4pt; "> <br> <br> </span>
Sobald dieses Fenster geschlossen wird, startet der PC SOFORT neu.
<ol>
<li>
Lesen Sie die
<a href="http://dieseyer.de/dse-wsh-mehr-hta.html" >HTA Infos</a>
aufmerksam durch.
<br>
Tip: Drucken Sie sich die
<a href="http://dieseyer.de/dse-wsh-mehr-hta.html" >HTA Infos</a>
aus.
</li>
<span style="font-size:4pt; "> <br> <br> </span>
<li>
Ist dieses Fenster geschlossen, wird Ihr Rechner automatisch neu gestartet.
</li>
<span style="font-size:4pt; "> <br> <br> </span>
<li>
Nach Abschluss des Neustarts können Sie wieder 'normal' arbeiten.
Die genaue Vorgehensweise entnehmen Sie bitte der
<a href="http://dieseyer.de/dse-wsh-mehr-hta.html" >HTA Infos</a>
</li>
</lo>
<br> <br>
<Center id=RestZeitAnzeige> </Center>
<span style="font-size:4pt; "> <br> <br> </span>
<span style="font-size:4pt; "> <br> <br> </span>
<Center>
<INPUT TYPE="button" value="Fenster schliessen und PC sofort neu starten" onClick="Auswahl()" >
</Center>
</body>
#########################################################################
>>> 1service_serviceentfernen.vbs <<<
'*** v9.7 *** www.dieseyer.de *******************************
'
' Datei: 1service_serviceentfernen.vbs
' aus vbsbeimsystemstart.vbs v8.4
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Const Dienst1 = "1Service" ' DienstName auf dem ZielPC
Dim ZielPC
' Dim ZielVerz, ZielWinDir, ZielDatei, Txt, Tst
' LOG-Datei-Namen festlegen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim LogDatei
LogDatei = ""
Trace32Log "Starte: """ & ZielPC & """ " , 1 ' LOG-Datei ist VBS-Name
' Dim aktVerz : aktVerz = WshShell.ExpandEnvironmentStrings("%WinDir%") & "\system32\CCM\Inst.LOG\"
Dim AktVerz : AktVerz = Replace( WScript.ScriptFullName, WScript.ScriptName, "" ) ' mit "\" am Ende!!!
' If InStr( VBSStart, "\" ) > 1 Then AktVerz = Mid( VBSStart, 1, InStrRev( VBSStart, "\" ) )
LogDatei = WScript.ScriptFullName
LogDatei = Mid( LogDatei, 1, InStrRev( LogDatei, "." ) - 1 ) ' alles bis zum letzten Punkt
LogDatei = LogDatei & "_" & ZielPC & ".log" ' LogDatei enthält jetzt PCNamen
LogDatei = AktVerz & fso.GetBaseName( WScript.ScriptFullName )& "_" & ZielPC & ".log" ' LogDatei enthält jetzt PCNamen
' Trace32Log "-", 0 ' erstellt neue LogDatei (wegen 0)
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
Trace32Log "044 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "045 :: LogDatei: " & LogDatei, 1
Trace32Log "046 :: AktVerz: " & AktVerz, 1
Trace32Log "047 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "048 :: Angemeldeter User: " & WSHNet.UserName, 1
Trace32Log "049 :: ZielPC: " & ZielPC, 1
Call ServiceEntfernen( ".", Dienst1 )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "062 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
LogDatei = "" : Trace32Log "Abgearbeitet: """ & ZielPC & """ " , 1 ' LOG-Datei ist VBS-Name
WScript.Quit
'*********************************************************
Sub ServiceEntfernen( PC, Dienst )
'*********************************************************
Trace32Log "071 :: START: Sub ServiceEntfernen( """ & PC & """, """ & Dienst & """ )", 1
Dim objWMIService, colServices, objService
Dim Txt
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colServices
objService.StopService() : Trace32Log "079 :: Stopanforderung . . . ", 1
WScript.Sleep 3*1000
objService.Delete() : Trace32Log "081 :: Löschanforderung . . . ", 1
Next
Set objWMIService = nothing
Set colServices = nothing
Txt = ""
' Test, ob Dienst vorhanden ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\" & PC & "\root\cimv2")
Set colServices = objWMIService.ExecQuery ("Select * From Win32_Service" )
For Each objService in colServices
If objService.DisplayName = Dienst Then Txt = """" & objService.DisplayName & """ (" & objService.State & ")"
Next
Txt = "Der Dienst """ & Dienst & """ wurde von """ & PC & """ entfernt."
' If Len( Txt ) > 5 Then MsgBox now() & vbCRLF & Txt , , "095 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "096 :: " & Txt, 1
If Len( Txt ) > 5 Then Exit Sub
Txt = "FEHLER: Der Dienst """ & Dienst & """ konnte nicht von """ & PC & """ entfernt werden."
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "100 :: " & WScript.ScriptName
Trace32Log "101 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "103 :: " & "= = = E N D E = = ="
WScript.Quit
End Sub ' ServiceEntfernen( PC, Dienst )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 1und1_htmlstatistic_nach_html.vbs <<<
'*** v10.3 *** www.dieseyer.de ****************************
'
' Datei: 1und1_htmlstatistic_nach_html.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ist der Provider der eigenen Site 1&1, befindet sich im
' Verzeichnis ftp://[site]/logs/traffic.html
' die Zugriffs-Statistik der letzten 12 Monate.
' Sind diese Dateien über mehrere Jahre in einem Verzeichnis
' nach dem Muster "[Jahr]-[Monat].html" gespeichert, erstellt
' dieses Skript eine Kurzübersicht als HTML-Datei - vergl.
' http://dieseyer.de/dse-statistic.html
'
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Dim QuellVerz : QuellVerz = "D:\dieseyer.xxx\dieseyer.html"
Const Zoom = 1.75
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( "", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log "033 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "034 :: LogDatei: " & LogDatei, 1
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "036 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim Txt, Tst, Tyt, i, arrDaten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDaten = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "044 :: UBound( arrDaten ): " & UBound( arrDaten ), 1
' arrayZeigen( arrDaten )
ReDim Preserve Zeile( 0 )
For i = LBound( arrDaten ) to UBound( arrDaten )
arrDaten( i ) = DatumUndAnzahl( arrDaten( i ) )
Next
' arrayZeigen( arrDaten )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' QuickSort arrDaten, LBound( arrDaten ), UBound( arrDaten )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDaten )
Dim FileOut
Set FileOut = fso.OpenTextFile( WSCript.ScriptFullName & ".html", 2, True ) ' 2 => neue Datei; 8 => Datei erweitern
FileOut.WriteLine "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">"
FileOut.WriteLine "<html>"
FileOut.WriteLine "<head>"
FileOut.WriteLine "<meta http-equiv=""content-type"" content=""text/html; charset=windows-1250"">"
FileOut.WriteLine "<title></title>"
FileOut.WriteLine "</head>"
FileOut.WriteLine "<body>"
' FileOut.WriteLine "<pre><tt>"
For i = UBound( arrDaten ) to LBound( arrDaten ) Step -1 ' beginnend mit den neusten
' For i = LBound( arrDaten ) to UBound( arrDaten ) ' beginnend mit den ältesten
Txt = arrDaten(i)
If not Left( Txt, 15 ) = Left( Tst, 15 ) Then
' FileOut.WriteLine Mid( Txt, 17 ) ' & "<br>"
' FileOut.WriteLine Mid( Txt, 17 ) & vbTab & String( CInt( Mid( Txt, InStr( Txt, vbTab ) + 1 ) ), "|" )
' FileOut.WriteLine Mid( Txt, 17 ) & vbTab & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17 ), "#" )
' FileOut.WriteLine "<tt>" & Mid( Txt, 17 ) & " </tt>" & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17 ), "<b>|</b>" ) & "<br>"
FileOut.WriteLine "<tt>" & Mid( Txt, 17 ) & " </tt><b>" & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17, 2 ) * Zoom , "|" ) & "</b><br>"
' FileOut.WriteLine "<tt>" & Mid( Txt, 17 ) & " </tt><b>" & String( ( ( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17, 2) - 30 ) * 4 ), "|" ) & "</b><br>"
Tst = Txt
Else
arrDaten(i) = ""
End If
Next
' FileOut.WriteLine "</tt></pre>"
FileOut.WriteLine "</body>"
FileOut.WriteLine "</html>"
FileOut.Close
Set FileOut = nothing
' ArrayZeigen( arrDaten )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
Trace32Log "099 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
WScript.Quit
'*** v9.4 *** www.dieseyer.de ****************************
Function DatumUndAnzahl( Datei )
'*********************************************************
' Beispiel-Zeile:
' <!-- 2009-02-28 23.933 826 23.933 826 0.000 0 0.000 0 0.000 0 -->
' Interressant ist nur die Zahl der HTTP-Zugriffe (hier 826);
' diese befindet sich hinter dem 3. Leerschritt
' Die Prozedur gibt eine Zeichenkette zurückmit Monat und
' Anzahl der Zugriffe:
' "1.2.2009" & vbTab & 2.345
' alle Zeilen lesen und auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim FileIn : Set FileIn = FSO.OpenTextFile(Datei, 1 )
Dim Datum, Summe, Txt, Tst, i
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Txt = FileIn.Readline
If InStr( Txt, "<!-- 20" ) = 1 AND InStr( Txt, "-->" ) > 50 Then
If Datum = "" Then
' MsgBox Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "125 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 1 Then Datum = Left( txt, 15 ) & vbTab & "Jan. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "126 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 2 Then Datum = Left( txt, 15 ) & vbTab & "Feb. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "127 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 3 Then Datum = Left( txt, 15 ) & vbTab & "Mrz. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "128 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 4 Then Datum = Left( txt, 15 ) & vbTab & "Apr. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "129 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 5 Then Datum = Left( txt, 15 ) & vbTab & "Mai " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "130 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 6 Then Datum = Left( txt, 15 ) & vbTab & "Jun. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "131 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 7 Then Datum = Left( txt, 15 ) & vbTab & "Jul. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "132 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 8 Then Datum = Left( txt, 15 ) & vbTab & "Aug. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "133 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 9 Then Datum = Left( txt, 15 ) & vbTab & "Sep. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "134 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 10 Then Datum = Left( txt, 15 ) & vbTab & "Okt. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "135 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 11 Then Datum = Left( txt, 15 ) & vbTab & "Nov. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "136 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 12 Then Datum = Left( txt, 15 ) & vbTab & "Dez. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "137 :: " & CInt( Mid( Txt, 11, 2 ) )
End If
If Datum = "" Then Datum = Mid( Txt, 6, 10 ) & vbTab & CDate( Mid( Txt, 14, 2 ) & "." & Mid( Txt, 11, 2 ) & "." & Mid( Txt, 6, 4 ) )
If Datum = "" Then Datum = CDate( "1." & Mid( Txt, 11, 2 ) & "." & Mid( Txt, 6, 4 ) )
Tst = Split( Txt, " ", -1, 1)
Summe = Summe + CLng( Tst( 3 ) )
End If
Loop
FileIn.Close
Set FileIn = nothing
' MsgBox Datum & vbTab & Summe & vbCRLF & "Datei:" & vbTab & Datei, , "148 :: "
DatumUndAnzahl = Datum & vbTab & Round( Summe / 1000, 0 )
DatumUndAnzahl = Datum & vbTab & CSng( Summe )
End Function ' DatumUndAnzahl( Datei )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "203 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Dim i, oFolder, oFiles, DateiX
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolder = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v8.3 *** www.dieseyer.de *******************************
Function QuickSort( vntArray, intVon, intBis )
'************************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 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
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 ' QuickSort( vntArray, intVon, intBis )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "378 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "379 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 2-5mal-input-ds.vbs <<<
'v4.B***************************************************
' File: 2-5mal-input.vbs
' Autor: W.Schmelz (verändert: dieseyer@gmx.de)
' http://source-center.de/forum/showthread.php?t=1738
'
' http://dieseyer.de
'
' zerlegt / extrahiert aus der Eingabe in eine
' InputBox mehrere Eingaben.
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, Txt1, Txt2, Txt3, Txt4, Txt5
Dim Eingabe, i, Tst
Dim Sym : Sym ="#" ' Trennsymbol " # " evtl. anpassen
Dim Titel : Titel =" Input - Box mit 2 bis 5 Einträgen "
' Streichen oder Hinzufügen einer Schleife am Ende ändert Höchstzahl der Einträge !
'*******************************************************
Txt = Txt & "Bitte mit Abtrennung durch " & Sym & " eintragen" & VbCRLF & VbCRLF
Txt = Txt & "und dabei auf die Reihenfolge achten!" & VbCRLF & VbCRLF & VbCRLF
Txt = Txt & "1) Die Pers. Nr. z. B. A 7770007700" & VbCRLF & VbCRLF
Txt = Txt & "2) Die Telefonvorwahl z. B. 02374" & VbCRLF & VbCRLF
Txt = Txt & "3) Die Telefon - Nr. z. B. 77777" & VbCRLF & VbCRLF
Txt = Txt & "4) Name : Schulze - Bochum, Karl - Heinz" & VbCRLF & VbCRLF
Txt = Txt & "4) und noch : . . . " & VbCRLF & VbCRLF & VbCRLF
Txt = Txt & "Pers.Nr. " & Sym & " Vorwahl " & Sym & " Telefon " & Sym & " Name " & Sym & " Sonstiges"
Eingabe = " A788 # 0711 # 540367# Dseyer#doof " ' zum Testen
Eingabe = InputBox( VbCRLF & Txt & VbCRLF, Titel, Eingabe )
If Eingabe="" then WScript.Quit
If not Right( Eingabe, 1 ) = Sym then Eingabe = Eingabe & Sym ' Falls Symbol rechts vergessen!
If Left( Eingabe, 1 ) = Sym then Eingabe = Mid( Eingabe, 2 ) ' Falls Symbol links!
' Die Eingabenfolge wird gemäß den " # " in Abschnitte zerlegt
' und die Teile als Variablen " Txti " definiert
Txt = ""
Tst = Split( Eingabe, Sym ) ' Eingabe aufteilen und in Array Tst() ablegen
for i = LBound( Tst ) to UBound( Tst ) ' jeden Teil auswerten
If Left( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 2 )
If Left( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 2 )
If Right( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 1, Len( Tst(i) ) -1 )
If Right( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 1, Len( Tst(i) ) -1 )
' MsgBox i & vbTab & "==>" & Tst(i) & "<==" , , "Txt" ' zum Testen
if i = 0 Then Txt1 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 1 Then Txt2 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 2 Then Txt3 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 3 Then Txt4 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 4 Then Txt5 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
next
' MsgBox Txt, , "Txt" ' zum Testen
Ende ' Sub - Aufruf
WScript.Quit
'**************************************************************
Sub Ende
'**************************************************************
' Kontrollmeldung:
Txt=VbCRLF&VbCRLF
Txt=Txt&"1) Die Pers. Nr. ist "& Txt1 &VbCRLF&VbCRLF
Txt=Txt&"2) Die Telefonvorwahl ist "& Txt2 &VbCRLF&VbCRLF
Txt=Txt&"3) Die Telefon - Nr. ist "& Txt3 &VbCRLF&VbCRLF
Txt=Txt&"4) Name ist "& Txt4 &VbCRLF&VbCRLF
Txt=Txt&"5) und noch ist "& Txt5 &VbCRLF&VbCRLF
MsgBox Txt,,Titel
End Sub ' Ende
#########################################################################
>>> 2-5mal-input.vbs <<<
'v4.B***************************************************
' File: 2-5mal-input.vbs
' Autor: W.Schmelz
' http://source-center.de/forum/showthread.php?t=1738
'
' http://dieseyer.de
'
' zerlegt / extrahiert aus der Eingabe in eine
' InputBox mehrere Eingaben.
'*******************************************************
Option Explicit
Dim Txt, Txt1, Txt2, Txt3, Txt4, Txt5
Dim Laenge, Sym, i
Dim Zahl1, Zahl2, Zahl3, Zahl4, Zahl5
Dim Rechts, Rechts1, Rechts2, Rechts3, Rechts4, Rechts5
Dim Links, Links1, Links2, Links3, Links4, Links5
Dim Eingabe, Eingabe1, Eingabe2, Eingabe3, Eingabe4, Eingabe5
Dim Titel : Titel =" Input - Box mit 2 bis 5 Einträgen "
' Streichen oder Hinzufügen einer Schleife am Ende ändert Höchstzahl der Einträge !
' ************************************************
Txt=Txt&"Bitte mit Abtrennung durch # eintragen"&VbCRLF&VbCRLF
Txt=Txt&"und dabei auf die Reihenfolge achten !"&VbCRLF&VbCRLF&VbCRLF
Txt=Txt&"1) Die Pers. Nr. z. B. A 7770007700"&VbCRLF&VbCRLF
Txt=Txt&"2) Die Telefonvorwahl z. B. 02374"&VbCRLF&VbCRLF
Txt=Txt&"3) Die Telefon - Nr. z. B. 77777"&VbCRLF&VbCRLF
Txt=Txt&"4) Name : Schulze - Bochum, Karl - Heinz"&VbCRLF&VbCRLF
Txt=Txt&"4) und noch : . . . "&VbCRLF&VbCRLF&VbCRLF
Txt=Txt&" Pers.Nr. # Vorwahl # Telefon # Name # Sonst "
Sym="#" ' Trennsymbol " # " evtl. sinngemäß ändern!
' *****************************************
Eingabe=InputBox (VbCRLF&Txt&VbCRLF,Titel,Eingabe)
If Eingabe="" then WScript.Quit
If not (Right(Eingabe,1)=Sym) then Eingabe=Eingabe&Sym ' Falls Symbol rechts vergessen!
If Left(Eingabe,1)=Sym then Eingabe=Mid(Eingabe,2) ' Falls Symbol links!
Eingabe1=Eingabe
Laenge=Len(Eingabe1)
' Die Eingabenfolge wird gemäß den " # " in Abschnitte zerlegt
' und die Teile als Variablen " Txti " definiert
Zahl1=0
i=1
Do until Rechts=Sym
Links=Left(Eingabe1,i)
Rechts=Right(Links,1)
i=i+1
Zahl1=Zahl1 +1 ' Zahl1 ist Länge der 1. Sequenz mit dem " # "
Loop
Txt1=Left(Links,Zahl1 -1)
Eingabe2=Right(Eingabe1,Laenge-Zahl1) ' Neufestlegung
If Eingabe2="" then Ende
Zahl2=0
i=1
Do until Rechts2=Sym
Links2=Left(Eingabe2,i)
Rechts2=Right(Links2,1)
i=i+1
Zahl2=Zahl2 +1
Loop
Txt2=Left(Links2,Zahl2 -1)
Eingabe3=Right(Eingabe2,Laenge-Zahl1-Zahl2)
If Eingabe3="" then Ende
Zahl3=0
i=1
Do until Rechts3=Sym
Links3=Left(Eingabe3,i)
Rechts3=Right(Links3,1)
i=i+1
Zahl3=Zahl3 +1
Loop
Txt3=Left(Links3,Zahl3 -1)
Eingabe4=Right(Eingabe3,Laenge-Zahl1-Zahl2-Zahl3)
If Eingabe4="" then Ende
Zahl4=0
i=1
Do until Rechts4=Sym
Links4=Left(Eingabe4,i)
Rechts4=Right(Links4,1)
i=i+1
Zahl4=Zahl4 +1
Loop
Txt4=Left(Links4,Zahl4 -1)
Eingabe5=Right(Eingabe4,Laenge-Zahl1-Zahl2-Zahl3-Zahl4)
If Eingabe5="" then Ende
Zahl5=0
i=1
Do until Rechts5=Sym
Links5=Left(Eingabe5,i)
Rechts5=Right(Links5,1)
i=i+1
Zahl5=Zahl5 +1
Loop
Txt5=Left(Links5,Zahl5 -1)
Ende ' Sub - Aufruf
WScript.Quit
'**************************************************************
Sub Ende
'**************************************************************
' Kontrollmeldung:
Txt=VbCRLF&VbCRLF
Txt=Txt&"1) Die Pers. Nr. ist "& Txt1 &VbCRLF&VbCRLF
Txt=Txt&"2) Die Telefonvorwahl ist "& Txt2 &VbCRLF&VbCRLF
Txt=Txt&"3) Die Telefon - Nr. ist "& Txt3 &VbCRLF&VbCRLF
Txt=Txt&"4) Name ist "& Txt4 &VbCRLF&VbCRLF
Txt=Txt&"5) und noch ist "& Txt5 &VbCRLF&VbCRLF
MsgBox Txt,,Titel
End Sub ' Ende
#########################################################################
>>> 7s-aufeingabewarten.vbs <<<
'*** v9.6 *** www.dieseyer.de *******************************
'
' Datei: 7s-AufEingabeWarten.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WshShell, Tst
Set WshShell = WScript.CreateObject("WScript.Shell")
Tst = WshShell.Popup("Möchten Sie vom Skript Ihr Alter in Tagen wissen?" & vbCRLF & vbCRLF & "Wenn nicht, beendet sich das Skript in 7s", 7, WScript.ScriptName, 4 + 32)
If not Tst = vbYes Then
MsgBox "Das ist das Ende . . .", vbInformation, WScript.ScriptName
WScript.Quit
End If
Tst = InputBox( "Bitte geben Sie Ihren Geburtstag ein:", WScript.Scriptname, "01.01.1999" )
If Tst = "" Then
MsgBox "Das war keine gültige Eingabe!" & vbCRLF & vbCRLF & "Das ist das Ende . . .", vbInformation, WScript.ScriptName
WScript.Quit
End If
MsgBox "Jeder, der am " & Tst & " geboren wurde, ist heute " & DateDiff( "d", CDate( Tst ), now() ) & " Tage alt.", , WScript.ScriptName
#########################################################################
>>> AcronisAlteTibEntfernen.vbs <<<
'*** v10.8 *** www.dieseyer.de *****************************
' Datei: AcronisAlteTibEntfernen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die anzugebebene Datei wird nicht gelöscht, aber ALLE
' Dateien in dem selben Verzeichnis mit der selben Datei-
' Erweiterung (Extension), die ein bestimmtes Alter haben,
' werden beim Skriptaufruf gelöscht!
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Const DateiBleibt = "\\benz-tspro\backup\acronis\benz-ts01\BENZ-TS01.tib"
Const Alter = 99 ' Dateien, die seit xxx Tagen nicht geändert wurden - außer DateiBleibt
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Const VielLog = "-Ja"
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( " ", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup vbTab & "= = = S T A R T = = =", 2, "037 :: " & WScript.ScriptName, vbInformation
Trace32Log "038 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "039 :: LogDatei: " & LogDatei, 1
Trace32Log "040 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "041 :: Angemeldeter User: " & WSHNet.UserName, 1
AcronisAlteTibEntfernen DateiBleibt, Alter
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.Popup vbTab & "= = = E N D E = = =", 2, "046 :: " & WScript.ScriptName, 4096 + vbInformation
Trace32Log "047 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log " ", 1
Wscript.Quit
'*** v10.8 *** www.dieseyer.de *****************************
Function AcronisAlteTibEntfernen( DateiBleibt, Alter )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Verz, DateiErw, oFiles, Datei, DateiTst, Txt, Tst, errTst, i, n
i = 0 : n = 0
Trace32Log "063 :: Alte Dateien sollen gelöscht werden - min. Alter der zu löschenden Dateien: " & Alter & "d", 1
Trace32Log "064 :: Alte Dateien sollen gelöscht werden - Änderungsdatum der Dateien am oder vor dem " & FormatDateTime( now() - Alter, 2) & " - aktuelles Datum: " & Date(), 1
If not fso.FileExists( DateiBleibt ) then
WSHShell.Popup vbTab & "Datei / Verzeichnis existiert nicht:" & vbCRLF & vbCRLF & DateiBleibt, 5, "067 :: " & WScript.ScriptName, 4096 + vbCritical
Trace32Log "068 :: Datei / Verzeichnis existiert nicht: " & DateiBleibt, 3
Exit Function
End If
Trace32Log "071 :: Alte Dateien sollen gelöscht werden - außer: " & DateiBleibt, 1
Verz = fso.GetParentFolderName( DateiBleibt )
If not fso.FolderExists( Verz ) then
WSHShell.Popup vbTab & "Verzeichnis existiert nicht:" & vbCRLF & vbCRLF & Verz, 5, "075 :: " & WScript.ScriptName, 4096 + vbCritical
Trace32Log "076 :: Verzeichnis existiert nicht: " & Verz, 3
Exit Function
End If
Trace32Log "079 :: Alte Dateien sollen gelöscht werden - Verzeichnis: " & Verz, 1
DateiErw = UCase( fso.GetExtensionName( DateiBleibt ) )
Trace32Log "082 :: Alte Dateien sollen gelöscht werden - Dateierweiterung (Extension): " & DateiErw, 1
Trace32Log "084 :: ", 1
Set oFiles = fso.GetFolder( Verz ).Files
For Each Datei In oFiles
DateiTst = "OK"
' Trace32Log "090 :: Datei wird geprüft: " & Datei.Path, 1
' Trace32Log "091 :: Letzte Dateiänderung: " & Datei.DateLastModified, 1
' Trace32Log "092 :: min. ALter: " & FormatDateTime( now() - Alter, 2) & " - " & Alter & "d", 1
' Trace32Log "093 :: ALtersunterschied zu heute: " & DateDiff( "d" , Datei.DateLastModified, Date() ) & "d", 1
' Trace32Log "094 :: Daeierweiterung: " & UCase( fso.GetExtensionName( Datei.Path ) ), 1
' MsgBox Datei.GetExtensionName, , "096 :: " : WScript.Quit
If VielLog = "Ja" Then Trace32Log "098 :: Datei wird geprüft: " & Datei, 1
If not UCase( fso.GetExtensionName( Datei.Name) ) = DateiErw Then DateiTst = "-OK" : If VielLog = "Ja" Then Trace32Log "100 :: Dateierweiterung stimmt nicht: " & UCase( fso.GetExtensionName( Datei ) ), 1
If DateDiff( "d" , Datei.DateLastModified, Date() ) < Alter Then DateiTst = "-OK" : If VielLog = "Ja" Then Trace32Log "102 :: Datei ist nicht alt genug - Alter: " & DateDiff( "d" , Datei.DateLastModified, Date() ), 1
If UCase( Datei ) = UCase( DateiBleibt ) Then DateiTst = "-OK" : Trace32Log "104 :: Datei soll bleiben (Ausnahme-Datei): " & Datei, 2
If not DateiTst = "OK" Then
If VielLog = "Ja" Then Trace32Log "107 :: Datei wird nicht gelöscht: " & Datei, 1
Else
Txt = Datei.path ' nach dem Löschen von Datei.Path ist, fehlt Datei.Path
Tst = Datei.DateLastModified & " = " & DateDiff( "d" , Datei.DateLastModified, Date() ) & "d alt."
If VielLog = "Ja" Then Trace32Log "111 :: Datei soll gelöscht werden: " & Txt, 1
On Error Resume Next
fso.DeleteFile Txt, True
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
if Len( errTst ) < 5 Then
Trace32Log "119 :: Datei ist Gelöscht: " & Txt & " - Dateidatum: " & Tst, 1
i = i + 1
Else
Trace32Log "122 :: Datei nicht löschbar: " & Txt & " - " & errTst, 3
n = n + 1
End if
End if
Next
Set oFiles = nothing
Set fso = nothing
Trace32Log "131 :: ", 1
Trace32Log "132 :: " & i & " Dateien sind gelöscht.", 1
If n > 0 Then Trace32Log "133 :: " & n & " Dateien konnten nicht gelöscht werden - wegen Fehler.", 2
Trace32Log "134 :: ", 1
End Function ' AcronisAlteTibEntfernen( DateiBleibt, Alter )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "223 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "224 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> ad-pcliste.vbs <<<
'*** v9.7 *** www.dieseyer.de *******************************
'
' Datei: ad-pcliste.vbs
' Autor: xxx.dexter.xxx@googlemail.com
' Auf: www.dieseyer.de
'
' http://www.source-center.de/forum/showthread.php?p=79678
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim arrPCAlle 'Zeichenketten-Array
Dim strPC 'Zeichenkette
Dim ErrorOccurred 'Boolesch
ErrorOccurred = FALSE
arrPCAlle = PCListePlusADScan("ou=laptops,OU=domain hardware")
arrPCAlle = PCListePlusADScan("ou=E010,ou=P4SWL,OU=Clients")
If Not ErrorOccurred Then
For Each strPC in arrPCAlle
Txt = Txt & strPC & vbCRLF
next
End If
MsgBox Txt, , "021 :: " & WScript.ScriptName
WScript.Quit
'*** v9.7 *** www.dieseyer.de *******************************
Function PCListePlusADScan( Argument )
'************************************************************
' Autor: xxx.dexter.xxx@googlemail.com
' Beschreibung ....: Liefert die Domänencomputer in einem Array zurück. STANDARD: Gesamte Domäne
' Parameter .......: Argument(Syntax <[OU]|[Suchbereich]>) als Zeichenkette
' Rückgabewert ....: Computer als Zeichenketten-Array
'*** Konstanten
Const INDEX_OU = 0
Const INDEX_SCOPE = 1
Const ADS_SCOPE_BASE = 0
Const ADS_SCOPE_ONELEVEL = 1
Const ADS_SCOPE_SUBTREE = 2
'*** Variabeln
Dim RootDSE 'RootDSE-Objekt
Dim ADObject 'Active Directory-Object
Dim AdoCnn 'AdoConnection-Objekt
Dim AdoCmd 'AdoCommand-Objekt
Dim AdoRst 'AdoRecordSet-Objekt
Dim OUDetected 'Boolesch
Dim ScopeDetected 'Boolesch
Dim ValidParameter 'Boolesch
Dim ADsPath 'Zeichenkette
Dim SearchScope 'Zeichenkette
Dim Arguments 'Zeichenketten-Array
Dim Computer() 'Zeichenketten-Array
Dim ErrorNumber 'Ganzahl
Dim i 'Ganzzahl
'*** Bindung an den Stamm der Verzeichnisses aufbauen
ON ERROR RESUME NEXT
Set RootDSE = GetObject("ldap://rootDSE")
If Err.Number <> 0 Then
ErrorOccurred = True
ErrorNumber = Err.Number
Err.Clear
On Error GoTo 0
MsgBox ADSIFehler(ErrorNumber), , "067 :: " & WScript.ScriptName
EXIT FUNCTION
End If
'*** ENDREGION
'*** Variabeln initialisieren
ADsPath = UCase("LDAP://" & RootDSE.Get("rootDomainNamingContext"))
SearchScope = ADS_SCOPE_SUBTREE
OUDetected = FALSE
ScopeDetected = FALSE
ValidParameter = FALSE
'*** ENDREGION
'*** Visual Basic Skript unterstützt keine optionalen Parameter!
Arguments = Split(Argument, "|")
Select Case UBound(Arguments)
Case -1
OUDetected = TRUE
ScopeDetected = TRUE
ValidParameter = TRUE
Case 0
OUDetected = TRUE
ValidParameter = TRUE
Case 1
OUDetected = TRUE
ScopeDetected = TRUE
ValidParameter = TRUE
Case Else
ErrorOccurred = True
MsgBox "Falsche Anzahlt von Argumenten wurde übergeben. " & Join(Arguments), , "096 :: " & WScript.ScriptName
EXit Function
End Select
If ValidParameter Then
If OUDetected Then
If Not Arguments(INDEX_OU) = "" Then
ADsPath = UCase("LDAP://" & Arguments(INDEX_OU) & "," & RootDSE.Get("rootDomainNamingContext"))
End If
End If
If ScopeDetected Then
If Not Arguments(INDEX_SCOPE) = "" Then
Select Case LCase(Arguments(INDEX_SCOPE))
Case "base"
SearchScope = ADS_SCOPE_BASE
Case "onelevel"
SearchScope = ADS_SCOPE_ONELEVEL
Case Else
ErrorOccurred = True
MsgBox "Der Suchbereich '" & Arguments(INDEX_SCOPE) & "' wird nicht unterstützt!", , "115 :: " & WScript.ScriptName
Exit Function
End Select
End If
End If
End If
'*** ENDREGION
'*** Die Gültigkeit des ADsPfades überprüfen.
ON ERROR RESUME NEXT
Set ADObject = GetObject(ADsPath)
If Err.Number <> 0 Then
MsgBox "Der Pfad '" & ADsPath & "' ist ungültig!", , "127 :: " & WScript.ScriptName
ErrorOccurred = True
ErrorNumber = Err.Number
Err.Clear
ON ERROR GOTO 0
MsgBox ADSIFehler(ErrorNumber), , "132 :: " & WScript.ScriptName
EXIT FUNCTION
End If
Set ADObject = Nothing
'*** ENDREGION
'*** Nach AD-Objekte mit der Abfragetechnologie Active Data Object suchen.
Set AdoCnn = CreateObject("ADODB.Connection")
AdoCnn.Provider = "ADsDSOObject"
AdoCnn.Open "Active Directory Provider"
Set AdoCmd = CreateObject("ADODB.Command")
Set AdoCmd.ActiveConnection = AdoCnn
With AdoCmd
.CommandText = "SELECT Name FROM '" & ADsPath & "' WHERE objectClass='computer'"
.Properties("Page Size") = 1000
.Properties("Searchscope") = SearchScope
.Properties("Sort On") = "Name"
Set AdoRst = .Execute
End With
'*** ENDREGION
'*** Array für die RÜckgabe aufbereiten
i = 0
Do Until AdoRst.EOF
ReDim Preserve Computer(i)
Computer(i) = AdoRst.Fields("Name").Value
AdoRst.MoveNext
i = i + 1
Loop
'*** ENDREGION
PCListePlusADScan = Computer
End Function ' PCListePlusADScan( Argument )
'*** v9.7 *** www.dieseyer.de *******************************
Function ADSIFehler( ByVal ErrorCode )
'************************************************************
' Autor: xxx.dexter.xxx@googlemail.com
' Beschreibung ....: Wertet die Fehlernummer aus
' Parameter .......: Int Errorcode
' Rückgabewert ....: Fehlerbeschreibung Als Zeichenkette
' Notiz ...........: Allgemeine ADSI-Fehler (http://msdn.microsoft.com/en-us/libr...40(VS.85).aspx)
' LDAP-Fehler für ADSI (http://msdn.microsoft.com/en-us/libr...28(VS.85).aspx)
' LDAP-Fehler für ADSI 2.0 (http://msdn.microsoft.com/en-us/libr...30(VS.85).aspx)
Dim AdsErrorDict 'Dictionary-Objekt
Dim HexErrorCode 'Hex-Zahl
Dim ErrorDescription 'ZeichenKette
Dim ErrorMessage 'Zeichenkette
Set ADsErrorDict = CreateObject("Scripting.Dictionary")
HexErrorCode = Hex(ErrorCode)
ADsErrorDict.Add "800401E4", "INVALID_SYNTAX"
ADsErrorDict.Add "80005000", "E_ADS_BAD_PATHNAME"
ADsErrorDict.Add "80005001", "E_ADS_INVALID_DOMAIN_OBJECT"
ADsErrorDict.Add "80070005", "E_ADS_INSUFFICIENT_RIGHTS"
ADsErrorDict.Add "80070035", "NETWORKPATH_NOT_FOUND"
ADsErrorDict.Add "8007052E", "LDAP_INVALID_CREDENTIALS"
ADsErrorDict.Add "8007054B", "LDAP_DOMAIN_DOESNT_EXIST"
ADsErrorDict.Add "80072020", "LDAP_OPERATIONS_ERROR"
ADsErrorDict.Add "80072030", "LDAP_NOT_SUCH_OBJECT"
Select Case AdsErrorDict(HexErrorCode)
Case "INVALID_SYNTAX"
ErrorDescription = "Ungültiger Syntax!"
Case "E_ADS_BAD_PATHNAME"
ErrorDescription = "Ungültiger ADSI-Pfadnamen!"
Case "E_ADS_INVALID_DOMAIN_OBJECT"
ErrorDescription = "Unbekanntes ADSI-Domänenobjekt!"
Case "E_ADS_INSUFFICIENT_RIGHTS"
ErrorDescription = "Nicht ausreichende Zugriffsrechte!"
Case "NETWORKPATH_NOT_FOUND"
ErrorDescription = "Netzwerkpfad wurde nicht gefunden!"
Case "LDAP_INVALID_CREDENTIALS"
ErrorDescription = "Ungültige Anmeldeinformationen!"
Case "LDAP_DOMAIN_DOESNT_EXIST"
ErrorDescription = "Domäne nicht verfügbar!"
Case "LDAP_OPERATIONS_ERROR"
ErrorDescription = "Fehler bei der Operation aufgetreten!"
Case "LDAP_NOT_SUCH_OBJECT"
ErrorDescription = "Objekt ist nicht vorhanden!"
Case Else
ErrorDescription = "Unbekannter Fehler!"
End Select
ErrorMessage = "ADSI-Fehler" & vbCrLf & _
"Beschreibung: " & vbTab & ErrorDescription & vbCrLf & _
"Nr. (dez): " & vbTab & ErrorCode & vbCrLf & _
"Nr. (hex): " & vbTab & "0x" & HexErrorCode & vbCrLf
ADSIFehler = ErrorMessage
End Function ' ADSIFehler( ByVal ErrorCode )
#########################################################################
>>> adminstart.vbs <<<
'*** v2.1 *** www.dieseyer.de *******************************
'
' Datei: adminstart.vbs
' Autor: (C) 2002 by EagleSoft Ltd. / Roland Weisskopf
' Auf: www.dieseyer.de
'
' 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
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim strInterpreter(1)
Dim strRunAsPrefix, strScript, strUser, strPass, strRunCommand
Dim objShell
Dim intLoop, intMode, intSleepShort, intSleepLong
Dim blnPass
Const cCScript = 0
Const cWScript = 1
Const cProgram = 2
Dim strConsole
'* 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
' MsgBox strRunCommand, , "148 :: "
objShell.Run strRunCommand
WScript.Sleep intSleepLong
if blnPass then
objShell.AppActivate GetSystem32 & "\runas.exe"
WScript.Sleep intSleepShort
' MsgBox strPass & "{enter}" & vbCRLF & intMode & vbCRLF & GetSystem32 & "\runas.exe", , "156 :: "
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
#########################################################################
>>> aktuelledmtfdatetime.vbs <<<
'*** v9.C *** www.dieseyer.de ******************************
'
' Datei: AktuelleDMTFDateTime.vbs
' Autor: Philipp Reiser
' Autor: B.Flemming 29.07.2009
' Auf: www.dieseyer.de
'
' Wandelt die aktuelle Zeit in das DMTF DateTime Zeitformat.
' (mit Zeitverschiebung; Sommerzeit; DST)
'
'***********************************************************
Option Explicit
Dim Txt, i
' Warten, bis eine neue Sekunde beginnt
Do
WScript.Sleep 1
If InStr( Timer(), "," ) = 0 Then Exit Do
Loop
Do
Txt = Txt & AktuelleDMTFDateTime() & vbCRLF
' WScript.Sleep 1
i = i + 1 : If i > 35 Then exit Do
Loop
MsgBox Txt, , "015 :: " & WScript.ScriptName
MsgBox DMTFToDeTime( AktuelleDMTFDateTime ), , "017 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "20091112" ), , "019 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "200910021355" ), , "020 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "20090101023344" ), , "021 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "20090729102344.000000+120" ), , "022 :: " & WScript.ScriptName
WScript.Quit
'***********************************************************
'http://msdn.microsoft.com/en-us/library/aa387237(VS.85).aspx
'
'CIM-DATETIME
'yyyymmddHHMMSS.mmmmmmsUUU
'
'The following Field Description lists the fields in the formats.
'
'yyyy Four-digit year (0000 through 9999).
' Your implementation can restrict the supported range.
' For example, an implementation can support only the years 1980 through 2099.
'
'mm Two-digit month (01 through 12).
'dd Two-digit day of the month (01 through 31).
' This value must be appropriate for the month. For example, February 31 is not valid.
' However, your implementation does not have to check for valid data.
'
'HH Two-digit hour of the day using the 24-hour clock (00 through 23).
'MM Two-digit minute in the hour (00 through 59).
'SS Two-digit number of seconds in the minute (00 through 59).
'
'mmmmmm Six-digit number of microseconds in the second (000000 through 999999).
' Your implementation does not have to support evaluation using this field.
' However, this field must always be present to preserve the fixed-length nature of the string.
'
'mmm Three-digit number of milliseconds in the minute (000 through 999).
'
's Plus sign (+) or minus sign (-) to indicate a positive or negative offset from Coordinated Universal Times (UTC).
'
'UUU Three-digit offset indicating the number of minutes that the originating time zone deviates from UTC.
' For WMI, it is encouraged, but not required, to convert times to GMT (a UTC offset of zero).
'
'
'*** v9.C *** www.dieseyer.de ******************************
Function AktuelleDMTFDateTime()
'***********************************************************
Dim DMTF, Tst
Tst = Timer
' Die (aktuell) zehntel und hundertstel Sekunden ermitteln.
' Zeit mit zwei Nachkommastellen: 14:25:36,47
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If InStr( Tst, "," ) Then
Tst = Mid( Tst, InStr( Tst, "," ) + 1 )
Else
Tst = ""
End If
If Len( Tst ) < 2 Then Tst = Tst & "0"
If Len( Tst ) < 2 Then Tst = Tst & "0"
Tst = "." & Tst
' aktuelle DMTF-Zeit (ohne Nachkommastellen)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set DMTF = CreateObject("WbemScripting.SWbemDateTime")
DMTF.SetVarDate Now(), True
' aktuelle DMTF-Zeit um Nachkommastellen erweitern
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Replace( DMTF, ".00", Tst)
Set DMTF = nothing
AktuelleDMTFDateTime = Tst
End Function ' AktuelleDMTFDateTime()
'*** v8.6 *** www.dieseyer.de ******************************
Function Zeit2DMTFDateTime( Zeit )
'***********************************************************
' http://www.dmtf.org/standards/published_documents/DSP0004V2.3_final.pdf
Dim Tst, Txt, objWMIService, colTimeZone, objTimeZone, DaylightBias
Zeit = CDate( Zeit )
Txt = Year( Zeit )
Tst = Month( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Day( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Hour( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Minute( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Second( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colTimeZone = objWMIService.ExecQuery("Select * from Win32_TimeZone")
For Each objTimeZone in colTimeZone
Tst = objTimeZone.DaylightBias - objTimeZone.Bias
Next
Tst = Tst * - 1
Txt = Txt + ".000000+" & Tst : Txt = Replace( Txt, "+-", "-" )
Zeit2DMTFDateTime = Txt
End Function ' Zeit2DMTFDateTime( Zeit )
'*** v9.1 *** www.dieseyer.de ******************************
Function DMTFToDeTime( t )
'***********************************************************
' Tag Monat Jahr Stunden Minuten Sekunden
If Len( t ) = 8 Then DMTFToDeTime = Mid( t, 7, 2 ) & "." & Mid( t, 5, 2 ) & "." & Mid( t, 1, 4 ) & " 00:00"
If Len( t ) = 12 Then DMTFToDeTime = Mid( t, 7, 2 ) & "." & Mid( t, 5, 2 ) & "." & Mid( t, 1, 4 ) & " " & Mid( t, 9, 2 ) & ":" & Mid( t, 11, 2 )
If Len( t ) > 13 Then DMTFToDeTime = Mid( t, 7, 2 ) & "." & Mid( t, 5, 2 ) & "." & Mid( t, 1, 4 ) & " " & Mid( t, 9, 2 ) & ":" & Mid( t, 11, 2 ) & ":" & Mid( t, 13, 2 )
DMTFToDeTime = CDate( DMTFToDeTime )
End Function ' DMTFToDeTime( t )
#########################################################################
>>> alleprozesseundtasks.vbs <<<
'*** v9.8 *** www.dieseyer.de ******************************
'
' Datei: AlleProzesseUndTasks.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim AlleTxt, AlleArray, AlleDict
AlleTxt = AlleProzesseUndTasksText( "." )
' Ausgabe in Popup
CreateObject("WScript.Shell").PopUp "AlleProzesseUndTasksText" & vbCRLF & vbCRLF & AlleTxt, 7, "016 :: " & WScript.ScriptName
' Ausgabe in Datei; mit Datei öffnen
CreateObject("Scripting.FileSystemObject").OpenTextFile( WSCript.ScriptFullName & ".txt" , 2, true ).Write( AlleTxt )
CreateObject("WScript.Shell").Run """" & WSCript.ScriptFullName & ".txt" & """"
AlleArray = AlleProzesseUndTasksArray( "." )
WScript.Quit
'*** v9.B *** www.dieseyer.de ******************************
Function AlleProzesseUndTasksText( PC )
'***********************************************************
' WinTuC: TasksBewerten.hta UND TasksPrüfen.vbs
' Displaying the Services Running in All Processes
' http://www.microsoft.com/technet/scriptcenter/guide/sas_ser_arwi.mspx
' Außerhalb der Prozedur müssen folgende zwei Variablen definiert werden:'
' Variablen für "Function AlleProzesseUndTasksText( PC )"
' (aus ..\WinTuC_Zauberei\TasksBewerten.hta)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ReDim Preserve arrTasks( 4, 0 ) ' wird gefüllt von: Function AlleProzesseUndTasksText( PC )
' Dim dicTasks ' wird gefüllt von: Function AlleProzesseUndTasksText( PC )
' Set dicTasks = CreateObject("Scripting.Dictionary") ' enthält die Zahl, zum Zugriff auf ein arrTask() Element
' arrTasks( 0, m ) = ' "JA" Task muss laufen - sonst Fehlermeldung
' "NE" Task muss ruhen - sonst Fehlermeldung
' "NO" für nicht festgelegt - NIE Fehlermeldung
' arrTasks( 1, m ) = colProcessIDs(i) ' ist 0, wenn der Prozess NICHT läuft
' arrTasks( 2, m ) = Tst ' Tst enthält Befehlszeile des Prozess-Aufrufs;
' arrTasks( 3, m ) = objService.DisplayName
' arrTasks( 4, m ) = objService.Description
Dim Txt, Tst, i, m
Dim objIdDictionary : Set objIdDictionary = CreateObject("Scripting.Dictionary")
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service")
Dim objService
For Each objService in colServices
If objIdDictionary.Exists(objService.ProcessID) Then
Else
objIdDictionary.Add objService.ProcessID, objService.ProcessID
End If
Next
Dim colProcessIDs
colProcessIDs = objIdDictionary.Items
m = 0
For i = 0 to objIdDictionary.Count - 1
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE ProcessID = '" & colProcessIDs(i) & "'")
For Each objService in colServices
On Error Resume Next
WScript.Sleep 33 ' ! Wird nur in VBS unterstützt; nicht in HTA!
' Durch das Sleep 33 wird die CPU-Last verringert;
' die Prozedur benötigt dadurch 3x so lange.
On Error Goto 0
' \svchost.exe wird manchmal nur als \svchost ausgegeben - das wird hier korrigiert
Tst = LCase( objService.PathName )
If InStr( Tst, ".exe" ) = 0 And InStr( Tst, "\svchost" ) > 1 Then Tst = Replace( Tst, "\svchost", "\svchost.exe" ) ' : MsgBox Tst, , "0875 :: " & Titel
Txt = Txt & vbCRLF & colProcessIDs(i) & " _" & m & "_ " & Tst & ": " & objService.DisplayName & "0875 ::: " & objService.Description
If dicTasks.Exists( objService.DisplayName ) Then
' if m < 3 OR m > 95 Then MsgBox "Gibts schon: " & objService.DisplayName & " " & dicTasks.Item( objService.DisplayName ), , "0879 :: " & Titel & "'Win32_Service'"
Else
dicTasks.Add objService.DisplayName, m
ReDim Preserve arrTasks( 4, m )
arrTasks( 0, m ) = "NO"
arrTasks( 1, m ) = colProcessIDs(i) ' ist 0, wenn der Prozess NICHT läuft
arrTasks( 2, m ) = Tst ' Tst enthält Befehlszeile des Prozess-Aufrufs;
arrTasks( 3, m ) = objService.DisplayName
arrTasks( 4, m ) = objService.Description
arrTasks( 4, m ) = "ID " & colProcessIDs(i) & " (" & objService.ProcessId & "): " & objService.Description & " (Win32_Service)"
' if m < 3 OR m > 95 Then MsgBox "Neu angelegt: >" & arrTasks( 3, m ) & "<" & vbCRLF & "ist Nr. " & dicTasks.Item( arrTasks( 3, m ) ), , "0891 :: " & Titel
m = m + 1
End If
' bisher war immer: objService.Caption = objService.DisplayName
' If not objService.Caption = objService.DisplayName Then MsgBox objService.Caption & vbCRLF & objService.DisplayName, , "0896 :: " & Titel
Next
Next
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", &h10 + &h20 )
Dim objItem
For Each objItem In colItems
Tst = Trim( objItem.CommandLine )
If isNull( Tst ) Then Tst = objItem.Name ' : MsgBox "'" & Tst & "'" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0904 :: " & Titel
' MsgBox "'" & Tst & "'" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0905 :: " & Titel
' einige Prozesse werden in Win32_Process und Win32_Service aufgeführt
If objIdDictionary.Exists( objItem.ProcessID ) Then
' If objIdDictionary.Exists( objItem.ProcessID ) OR objItem.ProcessID = 0 Then
Else
' On Error Resume Next
objIdDictionary.Add objItem.ProcessID, objItem.ProcessID
If err.Number > 0 Then Tst = Tst & " .. " & objItem.ProcessID
On Error Goto 0
If dicTasks.Exists( Tst ) Then Tst = Tst & " ,, " & m
If dicTasks.Exists( Tst ) Then
MsgBox "FEHLER: Gibts schon: '" & Tst & "' - Nr.: " & dicTasks.Item( Tst ) & " (" & m & ")" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0917 :: " & Titel
Else
' dicTasks.Add objItem.Name & " (" & objItem.ProcessId & ")", m
dicTasks.Add Trim( Tst ), m
ReDim Preserve arrTasks( 4, m )
arrTasks( 0, m ) = "NO"
arrTasks( 1, m ) = objItem.ProcessId ' ist 0, wenn der Prozess NICHT läuft
arrTasks( 2, m ) = Tst
arrTasks( 2, m ) = "" ' bei den Prozessen ist nicht der Prozessname sondern die CommandLine das entscheidende
arrTasks( 3, m ) = objItem.Name
arrTasks( 3, m ) = Tst ' bei den Prozessen ist nicht der Prozessname sondern die CommandLine das entscheidende
arrTasks( 4, m ) = objItem.Description
arrTasks( 4, m ) = "ID " & objItem.ProcessId & " (" & objItem.ParentProcessId & "): " & objItem.Description & " (Win32_Process)"
' if m < 3 OR m > 95 Then MsgBox "Neu angelegt: >" & arrTasks( 3, m ) & "<" & vbCRLF & "ist Nr. " & dicTasks.Item( arrTasks( 3, m ) ), , "0931 :: " & Titel & "'Win32_Process'"
m = m + 1
End If
End If
Next
Set colItems = nothing
Set colServices = nothing
Set objWMIService = nothing
Set objIdDictionary = nothing
On Error Resume Next ' sonst Fehler in TasksPrüfen.vbs
Txt = "0944 :: Taskliste ist erstellt. (" & Now() & ")" ' & Replace( Txt, vbCRLF, "<br>" )
window.setTimeout "InfoZeigen('" & Txt & "')" , 33
' window.setTimeout "ArrayZeigenZweiDimensionen( arrTasks )" , 333
Txt = "0949 :: Anzeige wird ""zusammen gebaut"" . . . (" & Now() & ")"
window.setTimeout "InfoZeigen('" & Txt & "')" , 66
window.setTimeout "TasksListeKonfigurationZeigen" , 99
End Function ' AlleProzesseUndTasksText( PC )
'*** v9.8 *** www.dieseyer.de ******************************
Function AlleProzesseUndTasksArray( PC )
'***********************************************************
' Displaying the Services Running in All Processes
' http://www.microsoft.com/technet/scriptcenter/guide/sas_ser_arwi.mspx
Dim Txt, Tst, i
Dim objIdDictionary : Set objIdDictionary = CreateObject("Scripting.Dictionary")
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
' Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service Where State <> 'Stopped'")
Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service")
Dim objService
For Each objService in colServices
If objIdDictionary.Exists(objService.ProcessID) Then
Else
objIdDictionary.Add objService.ProcessID, objService.ProcessID
End If
Next
Dim colProcessIDs
colProcessIDs = objIdDictionary.Items
For i = 0 to objIdDictionary.Count - 1
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE ProcessID = '" & colProcessIDs(i) & "'")
For Each objService in colServices
' \svchost.exe wird manchmal nur als \svchost ausgegeben - das wird hier korrigiert
Tst = LCase( objService.PathName )
If InStr( Tst, ".exe" ) = 0 And InStr( Tst, "\svchost" ) > 1 Then Tst = Replace( Tst, "\svchost", "\svchost.exe" ) ' : MsgBox Tst, , "096 :: "
Txt = Txt & vbCRLF & colProcessIDs(i) & " _ " & Tst & ": " & objService.DisplayName & " " & objService.Description
' bisher war immer: objService.Caption = objService.DisplayName
' If not objService.Caption = objService.DisplayName Then MsgBox objService.Caption & vbCRLF & objService.DisplayName, , "101 :: "
Next
Next
AlleProzesseUndTasksArray = Txt
End Function ' AlleProzesseUndTasksArray( PC )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 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
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 ' QuickSort( vntArray, intVon, intBis )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "210 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "211 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> 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
#########################################################################
>>> AnwRemoteStarten.hta <<<
</html>
<head>
<!--
'*** v9.2 *** www.dieseyer.de ****************************
'
' Datei: AnwRemoteStarten.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'*********************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
a:active { text-decoration:none; font-weight:bold; background-color:#cff; }
-->
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="Anwendungen Remote Starten"
SINGLEINSTANCE="yes"
>
<title>Anwendungen Remote Starten</title>
<style type="text/css">
body { font-size:9Pt; color:#ec0; font-weight:normal; font-family:verdana,arial,sans-serif; }
#KopfBlock { margin-top:-10px; height:87px; }
a:link { text-decoration:none; font-weight:bold; color:#ec0; }
a:visited { text-decoration:none; font-weight:bold; color:#ec0; }
a:hover { text-decoration:none; font-weight:bold; color:#226; background-color:#ec0; }
a:focus { text-decoration:none; font-weight:bold; background-color:#080; }
input { font-weight:bold; color:#226; border:4px #FFF outset; height:26px; width:95%; }
.LogStart { font-weight:normal; border:2px #FFF outset; height:1.5em; width:60px; }
.Check { font-weight:bold; margin-top:9px; border:0px #FFF outset; height:2em; width:2em; }
.PCSuche { font-weight:bold; font-size:10Pt; border:4px #FFF outset; height:26px; width:180px; }
.unsichtbar { font-weight:normal; border:0px #FFF outset; height:0px; width:0px; }
select { font-size:12pt; font-weight:normal; color:#226; border:4px #FFF outset; width:240px}
#ZeileLinks { font-family:fixedsys; margin-top:-1px; margin-left:-1px; float:left; padding:6px; width:25%; height:56px; border:1px #ec0 solid;
border-left:1px #ec0 solid; border-right:0px #ec0 solid; border-top:1px #ec0 solid; border-bottom:1px #ec0 solid; }
#ZeileRechts { margin-top:-1px; margin-left:-1px; float:left; padding:6px; width:75%; height:56px; border:1px #ec0 solid;
border-left:0px #ec0 solid; border-right:1px #ec0 solid; border-top:1px #ec0 solid; border-bottom:1px #ec0 solid; }
#Abstand { margin-left:-1px; margin-top:-1px;height:7px; border:0 px red solid; width:100%; padding:0px; font-size:0px; }
</style>
</head>
<script language="VBscript">
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const InfoJa = "-JA"
Dim LokalAnw : LokalAnw = "D:\dieseyer.neu\scr\timeset.vbs"
LokalAnw = "H:\dieseyer.neu\scr\timeset.vbs"
Dim RemotVerz : RemotVerz = "\Temp\scr\"
RemotVerz = "\Windows\Temp\"
RemotVerz = "\Temp\scr\"
Dim LokalVerz, AnwTxtLinks, AnwTxtRechts
Dim Titel : Titel = oHta.APPLICATIONNAME
Dim ErlaubteTaste
Dim AktVerz, HtaPfad, i
'' Dim BlockTxt, Kopf1Txt
Dim AnwAktive ' "JA" wenn eine Anwendung gestartet wurde, bis diese abgearbeitet ist
ReDim Preserve arrAufgAlleName( 0 ) : arrAufgAlleName( 0 ) = ""
ReDim Preserve arrAufgAlleDatei( 0 ) : arrAufgAlleDatei( 0 ) = ""
ReDim Preserve arrPCAlleNamen( 0 ) ' nur PCName
ReDim Preserve arrPCAlleDaten( 9, 0 ) ' PCName AnmeldeName AnmeldePasswort Status
' PCNameSyntaxTest "pc01"
' PCNameSyntaxTest "ap-pc"
' PCNameSyntaxTest "ds-amd"
' PCNameSyntaxTest "ds-t23"
' PCNameSyntaxTest "C010D1010055223"
' PCNameSyntaxTest "C010L00000A1EIP"
' PCNameSyntaxTest "C010L00000A07PW"
' PCNameSyntaxTest "C010L1010057445"
' PCNameSyntaxTest "M010D2500A1CUV"
' PCNameSyntaxTest "M010L25000A07PW"
' PCNameSyntaxTest "M010L2500057445"
Dim LogJa
Dim LogDatei
Dim AuswahlAlleAufg, AuswahlAllePCs, PCListeEing, PCListeType
'*********************************************************
Sub document_onKeyDown
'*********************************************************
Exit Sub
If window.event.keyCode = 13 AND ErlaubteTaste = 13 Then Call VVV()
End Sub
'*********************************************************
Function BeimLaden() ' ruft einige Routinen auf
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Dim HtaSelbst
Call HTASize
HtaSelbst = oHta.CommandLine ' der erste Parameter ist der komplette Pfad mit
' .hta-Datei, von " (Anführungszeichen) eingeschlossen
' If InStr( HtaSelbst, "~-_ENDE_-~" ) > 0 Then window.setTimeout "HtaBeenden()", 3*1000 : Exit Function
HtaSelbst = Replace( HtaSelbst, "~-_ENDE_-~", "" )
AktVerz = fso.GetParentFolderName( HtaSelbst ) ' : MsgBox "AktVerz: " & AktVerz, , "0134 :: "
AktVerz = Replace( AktVerz, """", "" ) ' : MsgBox "AktVerz: " & AktVerz, , "0135 :: "
LogDatei = AktVerz & "\" & Titel & ".log" ' : MsgBox LogDatei, , "0137 :: "
LokalVerz = fso.GetParentFolderName( LokalAnw )
AnwTxtLinks = fso.GetFileName( LokalAnw )
' Txt = Txt & "aus dem Verzeichnis " & fso.GetParentFolderName( LokalAnw )
Tst = LokalAnw
Tst = Replace( LokalAnw, fso.GetExtensionName( LokalAnw ), "log")
Txt = ""
Txt = Txt & "aus dem Verzeichnis " & fso.GetParentFolderName( LokalAnw ) & " "
Txt = Txt & "soll auf den Ziel-PCs nach <br>\\[ZielPC]\c$" & RemotVerz & " "
Txt = Txt & "kopiert und dort gestartet werden.<br>"
'' Txt = Txt & "[<a href=""" & Tst & """>" & Tst & "</a>] öffnen "
AnwTxtRechts = Txt
Call KopfAnzeigen
Call ZeilenAnzeigen
Exit Function
' MsgBox Tst, vbInformation, "0157 :: " & Titel
i = 0
i = i + 1 : window.setTimeout "PCNameAusZwischenablage()", i * 333
i = i + 1 : window.setTimeout "PCListeErmitteln()", i * 333
i = i + 1 : window.setTimeout "Block()", i * 333
If InStr( oHta.CommandLine, "~-_ENDE_-~" ) > 0 Then window.setTimeout "HtaBeenden()", 3*1000
End Function ' BeimLaden()
'*********************************************************
Sub HtaBeenden
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' MsgBox "Sub HtaBeenden", , "0176 :: " & Titel
window.setTimeout "document.all.Block.innerHTML = """"", 1*1000
window.setTimeout "document.all.Kopf1.innerHTML = """"", 2*1000
' window.setTimeout "document.all.Kopf2.innerHTML = """"", 3*1000
Dim Txt, Tst
Txt = Txt & "<span style=""font:175%"">" & Titel
Txt = Txt & "</span>"
Txt = Txt & "<span style=""font:120%; font-weight:bold; color:red; ""><br><br>''" & Titel & "'' wird beendet . . . "
Txt = Txt & "</span>"
document.all.Kopf.innerHTML = Txt
if fso.FileExists( Txt ) Then fso.DeleteFile Txt, True ' löschen der temp. VBS-Datei
' Verschieben der richtige nach temp. VBS-Datei
window.setTimeout "CreateObject(""Scripting.FileSystemObject"").MoveFile '" & Tst & "', '" & Txt & "'", 10
' Kopieren der temp. nach richtige VBS-Datei
window.setTimeout "CreateObject(""Scripting.FileSystemObject"").CopyFile '" & Txt & "', '" & Tst & "'", 1000
window.setTimeout "Self.Close()", 4 * 1000
End Sub ' HtaBeenden
'*********************************************************
Sub PCNameAusZwischenablage()
'*********************************************************
Dim Tst
' Zwischenablage für PCNameSyntaxTest vorbereiten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = document.parentwindow.clipboardData.GetData( "text" )
' MsgBox VarType( Tst ), , "0212 :: "
If VarType( Tst ) <> 8 Then Exit Sub
Tst = Replace( Tst, vbCRLF, "" )
Tst = Replace( Tst, vbLF, "" )
Tst = Replace( Tst, vbCR, "" )
Tst = Replace( Tst, " ", "" )
Tst = Replace( Tst, """", "" )
Call PCNameSyntaxTest( Tst )
End Sub ' PCNameAusZwischenablage()
'*********************************************************
Function ZeitSubtrahieren( ZeitTxt )
'*********************************************************
Dim Txt, Par1
If ZeitTxt = "" Then ZeitSubtrahieren = "" : Exit Function
If InStr( ZeitTxt, "d" ) Then Par1 = "d" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "d"
If InStr( ZeitTxt, "h" ) Then Par1 = "h" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "h"
If InStr( ZeitTxt, "m" ) Then Par1 = "m" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "n"
If InStr( ZeitTxt, "min" ) Then Par1 = "min" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "n"
ZeitSubtrahieren = CDate( DateAdd( Par1, Txt * -1, now() ) )
MsgBox "ZeitTxt >" & ZeitTxt & "<" & vbCRLF & "Txt >" & Txt & "<" & vbCRLF & "ZeitSubtrahieren >" & ZeitSubtrahieren & "<" & vbCRLF & "Jetzt: " & now(), , "0240 :: "
End Function ' ZeitSubtrahieren( ZeitTxt )
'*********************************************************
Sub AufgJePCStarten
'*********************************************************
Dim Txt, i, n, m, a, p
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' Dim FileOut : Set FileOut = fso.OpenTextFile( HauptVerz & "\" & _par, 2, True ) ' 2 => neue Datei; 8 => Datei erweitern
Dim AusgewAufg : Set AusgewAufg = document.getElementsByName("AufgAuswahl")
Dim AusgewPCs : Set AusgewPCs = document.getElementsByName("PCAuswahl")
' FileOut.WriteLine AltErgbNicht & ": " & ZeitSubtrahieren( AltErgbNichtX.Value ) ' : MsgBox "AltErgbNichtX.Value: " & AltErgbNichtX.Value , , "0255 :: "
' FileOut.WriteLine AltAufgEnde & ": " & ZeitSubtrahieren( AltAufgEndeX.Value ) ' : MsgBox "AltAufgEndeX.Value: " & AltAufgEndeX.Value , , "0256 :: "
For m = 0 to PCAuswahl.length-1
If PCAuswahl( m ).checked Then
' MsgBox arrPCAlleNamen( PCAuswahl( m ).Value ), , "0260 :: "
a = 0
For n = 0 to AusgewAufg.length-1
If AusgewAufg( n ).checked Then
a = 1 : i = i + 1
' MsgBox arrAufgAlleDatei( AusgewAufg( n ).Value ) & "::::" & arrPCAlleNamen( PCAuswahl( m ).Value ), , "0265 :: "
' Txt = Txt & vbCRLF & arrAufgAlleDatei( AusgewAufg( n ).Value ) & "::::" & arrPCAlleNamen( PCAuswahl( m ).Value )
Txt = Txt & vbCRLF & vbTab & arrAufgAlleDatei( AusgewAufg( n ).Value )
FileOut.WriteLine arrPCAlleNamen( PCAuswahl( m ).Value ) & " " & arrAufgAlleDatei( AusgewAufg( n ).Value )
End If
Next
If a = 0 Then
Txt = Txt & vbCRLF & arrPCAlleNamen( PCAuswahl( m ).Value )
FileOut.WriteLine arrPCAlleNamen( PCAuswahl( m ).Value ) & " \\XXXX\\"
End If
Txt = Txt & vbCRLF
End If
Next
FileOut.Close
Set FileOut = nothing
Self.close
Exit Sub
window.setTimeout "Self.close", 2*1000
' MsgBox i & " Aufgaben wurden abgesetzt . . ." & vbCRLF & Txt , , "0286 :: "
End Sub ' AufgJePCStarten
'*********************************************************
Sub AllePCsAusw
'*********************************************************
If AuswahlAllePCs = "checked" Then
AuswahlAllePCs = ""
Else
AuswahlAllePCs = "checked"
End if
Call ZeilenAnzeigen
End Sub ' AllePCsAusw
'*********************************************************
Sub AnwendungenSuche
'*********************************************************
LokalAnw = BFFStartVerzeichnis( AktVerz ) ' Prozedur-Aufruf
Call BeimLaden
' Call ZeilenAnzeigen
End Sub ' AnwendungenSuche
'*********************************************************
Sub PCListePlusListe
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim StartVerz, ListeDatei, FileIn, Tst, i, n
StartVerz = "C:\"
StartVerz = "D:\dieseyer.neu\scr\Neuer Ordner"
ListeDatei = BFFStartVerzeichnis( StartVerz ) ' Prozedur-Aufruf
If Len( ListeDatei ) < 5 Then Exit Sub
' Einlesen der Datei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = UBound( arrPCAlleNamen )
If Len( arrPCAlleNamen( i ) ) > 10 Then i = i + 1
Set FileIn = fso.OpenTextFile( ListeDatei, 1 )
Do While Not ( FileIn.atEndOfStream )
ReDim Preserve arrPCAlleNamen( i )
Tst = FileIn.Readline
arrPCAlleNamen( i ) = Tst
Call PCAlleDatenRedim( Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = i + 1
Loop
FileIn.close
Set FileIn = nothing
Call ZeilenAnzeigen
End Sub ' PCListePlusListe
'*********************************************************
Sub PCAlleDatenRedim( Txt )
'*********************************************************
Dim SplitZeichen, arrTst, Tst, i, n
' Das Trennzeichen für Split ermitteln
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SplitZeichen = "-OK"
' Das Trennezeichen kann im Passwort vorkommen, nicht aber im
' PCNamen und nicht im AnmeldeNamen;
' Das erste Trennzeichen muss nach dem PCNamen folgen, also höchstens an 16. Stelle
' Das Passwort wird frühstens nach dem 16. Zeichen beginnen; wahrscheinlich PCName + Trennzeichen + AnmeldeName > 16
Tst = """;""" : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 19 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0355 :: "
Tst = vbTab : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 17 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0356 :: "
Tst = " " : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 17 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0357 :: "
Tst = ";" : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 17 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0358 :: "
' Array erweitern, wenn letztes Array-Element nicht leer ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = UBound( arrPCAlleDaten, 2 ) : If not arrPCAlleDaten( 0, i ) = "" Then i = i + 1
ReDim Preserve arrPCAlleDaten( 9, i ) ' PCName AnmeldeName AnmeldePasswort Status
' Ist kein Trennzeichen für Split enthalten wird es wohl nur der PCName sein
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Txt ) < 16 AND SplitZeichen = "-OK" Then arrPCAlleDaten( 0, i ) = Txt
' Txt entspr. dem Trennzeichen für Split an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrTst = Split( Txt, SplitZeichen, -1, 1 )
For n = LBound( arrTst ) to UBound( arrTst )
Tst = arrTst( n )
If n = 0 Then arrPCAlleDaten( n, i ) = Tst
If n = 1 Then arrPCAlleDaten( n, i ) = Tst
If n = 2 Then arrPCAlleDaten( 2, i ) = Tst
If n > 2 Then arrPCAlleDaten( 2, i ) = arrPCAlleDaten( 2, i ) & SplitZeichen & Tst
' If n > 1 Then MsgBox "n: " & n & " i: " & i & vbCRLF & arrPCAlleDaten( n, i ), , "0381 :: "
Next
' Bei diesem Splitzeichen beginnt und endet Txt mit einem "
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If SplitZeichen = """;""" Then
arrPCAlleDaten( 0, i ) = Mid( arrPCAlleDaten( 0, i ), 2 )
arrPCAlleDaten( 2, i ) = Mid( arrPCAlleDaten( 2, i ), 1, Len( arrPCAlleDaten( 2, i ) ) -1 )
End If
Tst = Txt & vbCRLF & vbCRLF
Tst = Tst & "n: " & n & " i: " & i & " SplitZeichen: " & SplitZeichen & vbCRLF & vbCRLF
Tst = Tst & "PC:" & vbTab & arrPCAlleDaten( 0, i ) & vbCRLF
Tst = Tst & "Name:" & vbTab & arrPCAlleDaten( 1, i ) & vbCRLF
Tst = Tst & "Pwd:" & vbTab & arrPCAlleDaten( 2, i ) & vbCRLF
' MsgBox Tst, , "0398 :: "
End Sub ' PCAlleDatenRedim( Txt )
'*********************************************************
Sub ZeilenAnzeigen
'*********************************************************
Dim Farbe, Txt, i
Txt = Txt & "<span ID=""ZeileLinks"">"
Txt = Txt & AnwTxtLinks
Txt = Txt & "</span>"
Txt = Txt & "<span ID=""ZeileRechts"" style=""background-color:" & Farbe & """>"
Txt = Txt & AnwTxtRechts
Txt = Txt & "</span>"
Txt = Txt & "<span ID=Abstand></span>"
For i = LBound( arrPCAlleDaten, 2 ) to UBound( arrPCAlleDaten, 2 )
If Len( arrPCAlleDaten( 0, i ) ) > 3 Then
' Linker Teil der Zeile
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & "<span ID=""ZeileLinks"">"
If arrPCAlleDaten( 8, i ) = 0 Then
Txt = Txt & "<input " & AuswahlAllePCs & " class=""Check"" type=""checkbox"" name=""PCAuswahl"" value=""" & i & """> " & arrPCAlleDaten( 0, i )
Else
Txt = Txt & "<input " & " disabled class=""Check"" type=""checkbox"" name=""PCAuswahl"" value=""" & i & """> <u>" & arrPCAlleDaten( 0, i ) & "</u>"
End If
Txt = Txt & "</span>"
' Rechter Teil der Zeile
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If arrPCAlleDaten( 3, i ) = 0 Then Farbe = "#202060"
If arrPCAlleDaten( 3, i ) = 1 Then Farbe = "005" 'blau'
If arrPCAlleDaten( 3, i ) = 2 Then Farbe = "050" 'gün'
If arrPCAlleDaten( 3, i ) = 3 Then Farbe = "500" 'rot'
If arrPCAlleDaten( 3, i ) = 4 Then Farbe = "888" 'grau'
Txt = Txt & "<span ID=""ZeileRechts"" style=""background-color:" & Farbe & """>"
Txt = Txt & i & " "
' Txt = Txt & arrPCAlleDaten( 0, i ) & " "
' Txt = Txt & arrPCAlleDaten( 1, i ) & " "
' Txt = Txt & arrPCAlleDaten( 2, i ) & " "
' Txt = Txt & arrPCAlleDaten( 3, i ) & " "
Txt = Txt & arrPCAlleDaten( 4, i ) & " "
' Txt = Txt & arrPCAlleDaten( 8, i ) & " "
' Txt = Txt & arrPCAlleDaten( 9, i ) & " "
Txt = Txt & "</span>"
' Abstand zu nächsten Zeile
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Txt = Txt & "<span ID=Abstand></span>"
End If
Next
' Txt = Txt & "<br><br>" & "0453 :: " & Timer
document.all.BlockZeile.innerHTML = Txt
End Sub ' ZeilenAnzeigen
'*********************************************************
Sub AnwendungenStart
'*********************************************************
Dim i
AnwAktive = "-JA"
For i = 0 to PCAuswahl.length-1
If PCAuswahl( i ).checked Then
arrPCAlleDaten( 8, i ) = 1
arrPCAlleDaten( 3, i ) = 4 'grau'
arrPCAlleDaten( 9, i ) = "s" ' starten folgt
End If
Next
window.setTimeout "ZeilenAnzeigen", 33
window.setTimeout "RemoteAnwStarten", 333
End Sub ' AnwendungenStart
'*********************************************************
Sub RemoteAnwStarten
'*********************************************************
Dim Tst, i, m
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AusgewPCs : Set AusgewPCs = document.getElementsByName("PCAuswahl")
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0489 :: " & Timer() & " AnwAktive = " & AnwAktive
window.setTimeout "ZeilenAnzeigen", 33
If AnwAktive = "JA" Then Exit Sub
' Liste der PCs durchgehen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrPCAlleDaten, 2 ) to UBound( arrPCAlleDaten, 2 )
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0499 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
' PC soll Anwendung erhalten; durch "s"; => blau
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If arrPCAlleDaten( 9, i ) = "s" Then ' starten folgt
arrPCAlleDaten( 9, i ) = "a" ' aktiv
arrPCAlleDaten( 3, i ) = 1 'blau'
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0506 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
window.setTimeout "RemoteAnwStarten", 333
Exit For ' entspr. Exit Sub
End If
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0511 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
' PC erhält Anwendung; durch "a"; blau
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If arrPCAlleDaten( 9, i ) = "a" Then
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0516 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
AnwAktive = "JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrPCAlleDaten( 4, i ) = "0521 :: " & Timer()
' PC erreichbar?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not WMIpingOK( arrPCAlleDaten( 0, i ) ) Then
arrPCAlleDaten( 9, i ) = "e" ' ende folgt
arrPCAlleDaten( 3, i ) = 3 ' rot'
arrPCAlleDaten( 8, i ) = 0
arrPCAlleDaten( 4, i ) = "0529 :: PC ist nicht per WMI-Ping erreichbar.<br> " & Time()
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "RemoteAnwStarten", 333
Exit For ' entspr. Exit Sub
End If
arrPCAlleDaten( 4, i ) = "0537 :: Wird kopiert und gestartet: " & fso.GetFileName( LokalAnw ) & "<br>" & Time()
' Anwendung starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrPCAlleDaten( 3, i ) = 2
' AnwAktive = "-JA"
window.setTimeout "AnwendungJePCStarten '" & i & "', '" & arrPCAlleDaten( 0, i ) & "', '" & arrPCAlleDaten( 1, i ) & "', '" & arrPCAlleDaten( 2, i ) & "'", 111
window.setTimeout "RemoteAnwStarten", 333
Exit For ' entspr. Exit Sub
End If
Next
window.setTimeout "ZeilenAnzeigen", 33
End Sub ' RemoteAnwStarten
'*** v3.A*** www.dieseyer.de *******************************
Function LwFrei()
'**************************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim i
For i = 65+2 to 90
If not fso.DriveExists( Chr( i ) & ":" ) Then LwFrei = Chr( i ) & ":" : Exit Function
Next
End Function ' LwFrei()
'*********************************************************
Sub AnwendungJePCStarten( Nr, PC, User, Pwd )
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim oExec, Txt, Tst, Tyt, Ttt
Dim Lw
Lw = LwFrei
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Txt = "net use /D /Y " & Lw & ":" : Tst = ""
' Set oExec = CreateObject("WScript.Shell").Exec( Txt )
' If Not oExec.StdOut.AtEndOfStream Then
' Tst = Tst & oExec.StdOut.ReadAll
'' Tst = Tst & oExec.StdOut.ReadLine
' End If
' Set oExec = nothing
' MsgBox Tst, , "0584 :: "
' (neue) Netzverbindung herstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use " & Lw & ": \\" & PC & "\C$ " & Pwd & " " & "/User:" & PC & "\" & User : Tst = ""
Txt = "net use \\" & PC & "\IPC$ " & Pwd & " " & "/User:" & PC & "\" & User : Tst = ""
' InputBox Txt, Txt, Txt
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
Do While oExec.Status = 0
Tst = Tst & oExec.StdOut.ReadAll
Loop
' If Not oExec.StdOut.AtEndOfStream Then
' Tst = Tst & oExec.StdOut.ReadAll
' Tst = Tst & oExec.StdOut.Read(1)
' End If
Set oExec = nothing
' MsgBox Txt & vbCRLF & " => " & Tst, , "0600 :: "
' administrative Netzwerkfreigabe suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "" : i = 0
Do
i = i + 1
If not Txt = "" Then Exit Do
' If i > 4 Then MsgBox i, , "0608 :: "
If i > 4 Then Exit Do
If i = 1 Then Tst = "\\" & PC & "\c$"
If i = 2 Then Tst = "\\" & PC & "\d$"
If i = 3 Then Tst = "\\" & PC & "\e$"
If i = 4 Then Tst = "\\" & PC & "\f$"
If fso.FolderExists( Tst ) Then
Ttt = Tst & "\" & fso.GetTempName()
' MsgBox Ttt, , "0618 :: "
On Error Resume Next
err.Clear
fso.CreateFolder Ttt
On Error Goto 0
If fso.FolderExists( Ttt ) Then Txt = Tst : fso.DeleteFolder( Ttt )
Else
MsgBox "Fehlt:" & vbCRLF & vbCRLF & "]" & Tst & "[", , "0625 :: " & fso.GetTempName()
End if
Loop
If Txt = "" Then
arrPCAlleDaten( 4, Nr ) = "0630 :: Keine administrative Freigabe (C$/D$/E$/F$) auf dem PC erreichbar.<br> " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0645 :: "
Exit Sub
End If
Tyt = Split( RemotVerz, "\", -1, 1 )
For i = LBound( Tyt ) to UBound( Tyt )
Txt = Txt & "\" & Tyt( i ) & "\"
Txt = "\" & Replace( Txt, "\\", "\")
Txt = "\" & Replace( Txt, "\\", "\")
' Verzeichnis ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not fso.FolderExists( Txt ) Then
' On Error Resume Next
err.Clear
fso.CreateFolder( Txt )
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
arrPCAlleDaten( 4, Nr ) = "0665 :: Verzeichnis fehlt und kann nicht angelegt werden.<br> " & Txt & " - " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0680 :: "
Exit Sub
End If
MsgBox Txt & vbCRLF & vbCRLF & vbTab & "angelegt", , "0685 :: "
End If
Next
Tst = 0
' MsgBox LokalVerz & vbCRLF & Txt, , "0692 :: "
Tst = ShellFolderCopy( LokalVerz, Txt ) ' Prozeduraufruf
If not Tst = 0 Then
arrPCAlleDaten( 4, Nr ) = "0695 :: Fehler beim kopieren des (Ziel-) Verzeichnises; Zielverzeichnis:<br> " & Txt & " - " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0710 :: "
Exit Sub
End If
' MsgBox LokalVerz & vbcRLF & Txt & LokalAnw & vbcRLF & Tst, , "0715 :: "
LokalAnw = Txt & fso.GetFileName( LokalAnw )
Tst = "" : If fso.GetExtensionName( LokalAnw ) = "vbs" Then Tst = "wscript.exe "
MsgBox PC & vbCRLF & Tst & LokalAnw, , "0720 :: " ': Tst = 0
' Txt = "shutdown -r -f -t 10 -c """ & Titel & " - " & CreateObject("WScript.NetWork").UserName & """ -m \\" & PC
' MsgBox Txt, , "0722 :: "
' CreateObject("WScript.Shell").Run Txt, 0
Tst = 0
Tst = VbsRemoteStarten( PC, Tst & LokalAnw, Pwd, User )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not Tst = 0 Then
arrPCAlleDaten( 4, Nr ) = "0729 :: Konnte nicht gestartet werden (" & Tst & ") :<br> " & LokalAnw & " - " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0744 :: "
Exit Sub
End If
' MsgBox Txt & LokalAnw & vbCRLF & " => " & Tst, , "0749 :: "
' MsgBox "Nr: " & Nr & vbCRLF & "PC: " & PC & vbCRLF & "User: " & User & vbCRLF & "Pwd: " & Pwd & vbCRLF & "AnwAktive: " & AnwAktive , , "0750 :: "
Tst = LokalAnw
Tst = Replace( LokalAnw, fso.GetExtensionName( LokalAnw ), "log")
Txt = ""
Txt = Txt & "0756 :: "
Txt = Txt & "Erfolgreich gestartet (und beendet?):<br> "
Txt = Txt & LokalAnw & " - " & Time() & "<br>"
Txt = Txt & "<a href=""" & Tst & """>[" & Tst & "]</a> öffnen "
' Txt = Txt & "<input class=""LogStart"" type=""checkbox"" name=""PCAuswahl"" value=""" & i & """>"
arrPCAlleDaten( 4, Nr ) = Txt
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 2 'grün'
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "RemoteAnwStarten", 333
window.setTimeout "ZeilenAnzeigen", 33
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0780 :: "
End Sub ' AnwendungJePCStarten( Nr, PC, User, Pwd )
'*** v9.2 *** www.dieseyer.de *******************************
Function WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'************************************************************
' Aufruf z.B.: If not WMIpingOK( ZielPC ) Then MsgBox ZielPC & " ist nicht erreichbar." : WScript.Quit
Dim Tst, objPing, objStatus
On Error Resume Next
err.Clear
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & PCName & "'")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : WMIpingOK = "Fehler: " & Tst : Exit Function
WMIpingOK = True
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
' WScript.Echo("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'************************************************************
Function ShellFolderCopy (Quelle, Ziel) ' v2.C - http://dieseyer.de
'************************************************************
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Text
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME )
Text = "\system32"
If not "Windows_NT" = CreateObject("WScript.Shell").Environment("Process")("OS") then
Text = "\system"
End If
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
Text = fso.GetFileVersion( text ) ' Versionsinfo (der Shell32.dll) holen
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 )
Dim ShellApp
Set ShellApp = CreateObject("Shell.Application")
Dim oZielOrdner
Set oZielOrdner = ShellApp.NameSpace( Ziel )
'Const FOF_CREATEPROGRESSDLG = &H0 ' 0
'Const FOF_MULTIDESTFILES = &H1 ' 1
'Const FOF_CONFIRMMOUSE = &H2 ' 2
'Const FOF_SILENT = &H4 ' 4
'Const FOF_RENAMEONCOLLISION = &H8 ' 8
'Const FOF_NOCONFIRMATION = &H10 ' 16
'Const FOF_WANTMAPPINGHANDLE = &H20 ' 32
'Const FOF_ALLOWUNDO = &H40 ' 64
'Const FOF_FILESONLY = &H80 ' 128
'Const FOF_SIMPLEPROGRESS = &H100 ' 256
'Const FOF_NOCONFIRMMKDIR = &H200 ' 512
On Error Resume Next
oZielOrdner.CopyHere Quelle , 1 + 16
If err.number <> 0 Then
ShellFolderCopy = err.number
Else
ShellFolderCopy = 0
End If
On Error GoTo 0
Set ShellApp = nothing ' weil es nicht mehr gebraucht wird
Set oZielOrdner = nothing
End If
Set WSHShell = nothing
Set fso = nothing
End Function ' ShellFolderCopy () ' v2.C - http://dieseyer.de
'*** v8.4 *** www.dieseyer.de *******************************
Function VbsRemoteStarten( ZielPC, Progr, Pwd, User )
'************************************************************
Dim Tx, Tst, ProcessID
' Progr = "wscript.exe " & Progr ' Ziel-Anwendung
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\" & ZielPC & "\root\cimv2")
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & ZielPC & "\root\cimv2")
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ZielPC & "\root\cimv2")
Const WbemAuthenticationLevelPktPrivacy = 6
Dim objWbemLocator : Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator")
' Dim objWMIService : Set objWMIService = objwbemLocator.ConnectServer (ZielPC, "\root\cimv2:Win32_ProcessStartup", ZielPC & "\" & User, Pwd )
Dim objWMIService : Set objWMIService = objwbemLocator.ConnectServer (ZielPC, "\root\cimv2", ZielPC & "\" & User, Pwd )
objWMIService.Security_.authenticationLevel = WbemAuthenticationLevelPktPrivacy
' Dim objWbemLocator : Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator")
' Dim objConnection : Set objConnection = objwbemLocator.ConnectServer("WebServer", "root\cimv2", "fabrikam\administrator", "password", , "kerberos:WebServer")
' objConnection.Security_.ImpersonationLevel = wbemImpersonationLevelDelegate
'
'Set objSoftware = objConnection.Get("Win32_Product")
'errReturn = objSoftware.Install("\\atl-dc-02\scripts\1561_lab.msi",,True)
'
'
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\" & ZielPC & "\root\cimv2:Win32_ProcessStartup")
Dim objStartup : Set objStartup = objWMIService.Get("Win32_ProcessStartup")
Dim objConfig : Set objConfig = objStartup.SpawnInstance_
Const SW_NORMAL = 1 : objConfig.ShowWindow = SW_NORMAL
Dim objProcess : Set objProcess = objWMIService.Get("Win32_Process")
Trace32Log "0896 :: Soll gestartet werden: """ & Progr & """ ", 1
Tst = objProcess.Create( Progr, Null, Null, ProcessID )
' Tst = objProcess.Create( Progr, Null, objConfig, ProcessID )
' Tst = objProcess.Create( Progr, CreateObject("WScript.Shell").ExpandEnvironmentStrings("%WinDir%") & "\system32", objConfig, ProcessID )
If Tst <> 0 Then
MsgBox Tst & vbCRLF & ProcessID, , "900 :: "
Trace32Log "0901 :: Konnte NICHT gestartet werden - RC " & Tst, 3
VbsRemoteStarten = Tst
Else
MsgBox Tst, , "904 :: "
Trace32Log "0904 :: Ist gestartet - Process ID: " & ProcessID, 1
VbsRemoteStarten = Tst
End If
' c:\WINDOWS\system32\rundll32.exe"
End Function ' VbsRemoteStarten( ZielPC, Progr, Pwd, User )
'*********************************************************
Sub PCListePlusPC
'*********************************************************
Dim Txt, i
Txt = UCase( PCListePlusPCX.Value )
' PCName schon in der Auswahl?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrPCAlleNamen ) to UBound( arrPCAlleNamen )
If arrPCAlleNamen( i ) = Txt Then
MsgBox "Dieser PCName ist bereits in der Liste (als Nr. " & i + 1 & ")." & vbCRLF & vbCRLF & vbTab & Txt, , "1018 :: " & Titel
Exit Sub
End If
Next
' PCName in Array übernehmen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = UBound( arrPCAlleNamen ) : If not arrPCAlleNamen( UBound( arrPCAlleNamen ) ) = "" Then i = UBound( arrPCAlleNamen ) + 1
ReDim Preserve arrPCAlleNamen( i )
arrPCAlleNamen( i ) = Txt
Call ZeilenAnzeigen
End Sub ' PCListePlusPC
'*********************************************************
Sub KopfAnzeigen
'*********************************************************
Dim Txt
Txt = ""
Txt = Txt & "<span style=""font:175%"">" & Titel & "</span>"
Txt = Txt & "<span ID=Abstand></span>"
Txt = Txt & "Einlesen der Liste der PCs und der Anwendung, die gestartet werden soll."
Txt = Txt & "<span ID=Abstand></span>"
Txt = Txt & "<input class=""PCSuche"" onClick=""AnwendungenSuche()"" accesskey=""w"" type=""submit"" value=""Anwendung wählen"" > "
Txt = Txt & "<input class=""PCSuche"" onClick=""PCListePlusListe()"" accesskey=""d"" type=""submit"" value=""PC-Liste öffnen""> "
Txt = Txt & "<input class=""PCSuche"" onClick=""AnwendungenStart()"" accesskey=""s"" type=""submit"" value=""Anwendungen starten"" >"
Txt = Txt & "<span ID=Abstand></span>"
Txt = Txt & " <input Class=""unsichtbar"" onClick=""AllePCsAusw()"" accesskey=""a"" type=""checkbox"" >"
document.all.Kopf.innerHTML = Txt
End Sub ' KopfAnzeigen
'*********************************************************
Sub AlleAufgAusw
'*********************************************************
If AuswahlAlleAufg = "checked" Then
AuswahlAlleAufg = ""
Else
AuswahlAlleAufg = "checked"
End if
Call ZeilenAnzeigen
End Sub ' AlleAufgAusw
'*********************************************************
Sub AufgAusXML( XMLDatei )
'*********************************************************
' <Aufgabe>
' <AufgName>Benutzer des PCs</AufgName>
' <AufgInfo>Ermittelt letzte Anmeldung aller Benutzer mit Profil.</AufgInfo>
' <Progr1>
' <ProgrStart>wmi-ListLogonSessionInformation.vbs %PCName%</ProgrStart>
' <ProgrText>Letzter UserLogon-Zeitpunkt</ProgrText>
' <Info></Info>
' </Progr1>
' <Progr2>
' <ProgrStart>ZeitAlleUserProfile.vbs %PCName%</ProgrStart>
' <ProgrText>Auslesen des Profildatums</ProgrText>
' <Info></Info>
' </Progr2>
' </Aufgabe>
Dim i
Dim XMLDoc : Set XMLDoc = CreateObject("Msxml2.DOMDocument")
XMLDoc.async = false
XMLDoc.load( XMLDatei )
Dim Aufgabe, Node
Dim Aufgaben : Set Aufgaben = XMLDoc.selectNodes("//Aufgabe")
For Each Aufgabe in Aufgaben
For Each Node in Aufgabe.ChildNodes
If Node.BaseName = "AufgName" Then
i = UBound( arrAufgAlleName ) : If not arrAufgAlleName( UBound( arrAufgAlleName ) ) = "" Then i = UBound( arrAufgAlleName ) + 1
ReDim Preserve arrAufgAlleName( i )
ReDim Preserve arrAufgAlleDatei( i )
arrAufgAlleName( i ) = Node.Text ' : MsgBox i & " - " & arrAufgAlleName( i ), , "1096 :: "
arrAufgAlleDatei( i ) = XMLDatei ' : MsgBox i & " - " & arrAufgAlleDatei( i ), , "1097 :: "
End If
' If Node.BaseName = "AufgInfo" Then Node.Text
Next
Next
End Sub ' AufgAusXML( XMLDatei )
'*** v9.1 *** www.dieseyer.de *******************************
Function UserTempVerz
'************************************************************
' aus 'Scriptomatic v2.0' by 'The MS Scripting Guys'
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Environment", "WQL", &h10 + &h20 )
Dim objItem
For Each objItem In colItems
If InStr( UCase( objItem.UserName ), UCase( CreateObject("WScript.Network").Username ) ) > 0 Then
If objItem.SystemVariable = vbFalse Then UserTempVerz = objItem.VariableValue
End If
Next
If InStr( UCase( UserTempVerz ), "%USERPROFILE%" ) = 1 Then
UserTempVerz = Mid( UserTempVerz, Len( "%USERPROFILE%" ) + 1 )
UserTempVerz = CreateObject("WScript.Shell").Environment("PROCESS")("USERPROFILE") & UserTempVerz
End If
' MsgBox "UserTempVerz: " & UserTempVerz, , "1125 :: " : WScript.Quit
End Function ' UserTempVerz
'*********************************************************
Sub HTASize()
'*********************************************************
Dim Tst, Txt
On Error Resume Next
window.moveto 10, 10
Tst = document.body.clientWidth
If Tst < 800 Then Tst = 800 : window.resizeto Tst + 28, document.body.clientHeight + 31
On Error Goto 0
Exit Sub
On Error Resume Next
window.resizeto Tst, Txt
' window.moveto 0, 0
' window.moveto Links, Oben
' window.innerWidth
' window.resizeto Breite, Höhe ' Größe
' window.resizeto screen.width-20, screen.height-23
On Error Goto 0
End Sub ' HTASize()
'*********************************************************
Sub SchreibeXMLDatei( DateiName)
'*********************************************************
End Sub ' SchreibeXMLDatei
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i Then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "1205 :: " & Titel
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(0)
Dim i, oFolder, oFiles, DateiX
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
i = i + 1
Next
Set oFiles = nothing
Set oFolder = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v9.2 *** www.dieseyer.de *******************************
Function BFFStartVerzeichnis( Verz )
'************************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
'Set oFolder = oFSO.GetFolder("C:\")
Dim Dialog : Set Dialog = CreateObject("UserAccounts.CommonDialog")
' Dialog.Filter = "Text Files|*.txt|All Files|*.*" ' zeigt nur *.txt
' Dialog.Filter = "Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*" ' zeigt nur *.xls
Dialog.Filter = "Alle Dateien|*.*" ' zeigt nur *.* - also ALLES
' Dialog.Filter = "Textdateien|*.txt|Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*"
Dialog.FilterIndex = 2 ' von den drei auswählbaren Filtern wird der 2. eingesetzt
Dialog.InitialDir = Verz
Dialog.ShowOpen
BFFStartVerzeichnis = Dialog.FileName
End Function ' BFFStartVerzeichnis( Verz )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
</script>
<body onLoad="BeimLaden()" bgcolor="#202060" >
<Center id="Kopf"></Center>
<span id="BlockZeile"></span>
<!--
<span id="Kopf2"></span>
<span id="Kopf1"></span>
-->
<br>
<br>
<span id=InfoTxt></span>
</body>
</html>
#########################################################################
>>> arrayanzeigen-dateiinhalt.vbs <<<
'*** v10.5 *** www.dieseyer.de *****************************
'
' Datei: arrayanzeigen-dateiinhalt.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "027 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "028 :: LogDatei: " & LogDatei
Dim arrTst, arrUnSort
Dim Tst
Tst = WScript.ScriptFullName
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrTst = DateiInhalt( Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = "037 :: UBound( arrTst ) = " & UBound( arrTst )
LogEintrag Tst
MsgBox Tst, , "039 :: "
ArrayZeigen( arrTst )
arrUnSort = arrTst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrTst, LBound( arrTst ), UBound( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = "048 :: UBound( arrTst ) = " & UBound( arrTst )
LogEintrag Tst
MsgBox Tst, , "050 :: "
ArrayZeigen( arrTst )
Tst = "054 :: UBound( arrUnSort ) = " & UBound( arrUnSort )
LogEintrag Tst
MsgBox Tst, , "056 :: "
ArrayZeigen( arrUnSort )
Tst = WScript.ScriptFullName & ".txt"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call DateiSchreiben( arrTst, Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("WScript.Shell").Run "notepad " & Tst ' geschriebene Datei anzeigen
WSHShell.Popup "= = = E N D E = = =", 2, "067 :: " & WScript.ScriptName
LogEintrag "069 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WScript.Quit
'*** v10.5 *** www.dieseyer.de *****************************
Function DateiInhalt( DateiX )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileIn : Set FileIn = fso.OpenTextFile( DateiX, 1 )
Dim Txt, Tst, i
i = 0 : ReDim Preserve Zeile(i) : Zeile(i) = ""
Do While Not ( FileIn.atEndOfStream )
' Tst = Trim( FileIn.Readline )
Tst = FileIn.Readline
' If Len( Tst ) > 2 Then
Txt = Txt & Tst & vbCRLF
ReDim Preserve Zeile(i)
Zeile(i) = Tst
i = i + 1
' End If
Loop
' MsgBox Txt, , "095 :: "
If UBound( Zeile ) < 1 AND Zeile( UBound( Zeile ) ) = "" Then Zeile( UBound( Zeile ) ) = "LEER"
FileIn.Close
Set FileIn = nothing
DateiInhalt = Zeile
End Function ' DateiInhalt( DateiX )
'*** v8.C *** www.dieseyer.de ******************************
Sub DateiSchreiben( arrDaten, ZielDatei )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut, i
Set FileOut = fso.OpenTextFile( ZielDatei, 2, True ) ' 2 => neue Datei; 8 => Datei erweitern
FileOut.WriteLine UBound( arrDaten ) & " Zeilen werden geschrieben (" & now() & ")"
For i = LBound( arrDaten ) to UBound( arrDaten )
FileOut.WriteLine arrDaten(i)
Next
FileOut.Close
Set FileOut = nothing
End Sub ' DateiSchreiben( arrDaten, ZielDatei )
'*** v8.3 *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
On Error Resume Next
Dim LogDatei ' wurde die Variable LogDatei nicht außerhalb der Prozedur definiert
On Error Goto 0
' definiert, erfolgt dies jetzt hier:
' If LogDatei = "" Then LogDatei = "c:\" & WScript.Scriptname & ".log"
If LogDatei = "" Then LogDatei = WScript.ScriptFullName & ".log"
If LogTxt = "" Then ' eine neue .LOG-Datei wird erstellt, eine vorhandene überschrieben
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
LogTxt = Replace( LogTxt, vbTab, " " )
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 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
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 ' QuickSort( vntArray, intVon, intBis )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
' LogEintrag "255 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "256 :: "
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> arrayanzeigen-dateiliste.vbs <<<
'*** v7.C *** www.dieseyer.de ******************************
'
' Datei: arrayanzeigen-dateiliste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~~~
' Const QuellVerz = "C:\dieseyer.de\scr"
Dim QuellVerz : QuellVerz = Mid( WScript.ScriptFullName, 1, InStrRev( WScript.ScriptFullName, "\" ) )
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "035 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "036 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "038 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "046 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrDateiLst, LBound( arrDateiLst ), UBound( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "054 :: " & WScript.ScriptName
LogEintrag "056 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "108 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "109 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ******************************
Function Dateilisteholen( Verz )
'***********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
' LogEintrag "127 :: Ausgeschl: " & Ausgeschl
Dim i, oFolder, oFiles, DateiX
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "136 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolder = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 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
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 ' QuickSort( vntArray, intVon, intBis )
#########################################################################
>>> arrayanzeigen-verzeichnisliste.vbs <<<
'*** v10.2 *** www.dieseyer.de *****************************
'
' Datei: arrayanzeigen-verzeichnisliste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~~~
' Const QuellVerz = "C:\dieseyer.de\scr"
Dim QuellVerz : QuellVerz = Mid( WScript.ScriptFullName, 1, InStrRev( WScript.ScriptFullName, "\" ) )
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "036 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "037 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "039 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrVerzLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrVerzLst = Verzeichnislisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "046 :: UBound( arrVerzLst ): " & UBound( arrVerzLst )
ArrayZeigen( arrVerzLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrVerzLst, LBound( arrVerzLst ), UBound( arrVerzLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrVerzLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "062 :: " & WScript.ScriptName
LogEintrag "064 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "116 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "117 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v10.2 *** www.dieseyer.de *****************************
Function Verzeichnislisteholen( Verz )
'***********************************************************
' Die Prozedur
' Verzeichnislisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Verzeichnisse zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Verzeichnisse
' in Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
Dim i, oFolders, oSubFolder, VerzX
i = 0
Set oFolders = fso.GetFolder( Verz )
Set oSubFolder = oFolders.SubFolders
For Each VerzX In oSubFolder
ReDim Preserve VerzeichnislisteholenX(i)
' ReDim Preserve Verzeichnislisteholen(i)
VerzeichnislisteholenX(i) = VerzX
i = i + 1
Next
Set oSubFolder = nothing
Set oFolders = nothing
Verzeichnislisteholen = VerzeichnislisteholenX
End Function ' Verzeichnislisteholen( Verz )
'*** v7.C *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 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
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 ' QuickSort( vntArray, intVon, intBis )
#########################################################################
>>> attributechange.vbs <<<
'*** v3.B *** www.dieseyer.de *******************************
'
' Datei: attributechange.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Setzt die Attribute aller Dateien in dem übergebenen
' Verzeichnis zurück.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 Maus 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
#########################################################################
>>> autologonsetzen.hta <<<
<head>
<!--
'v9.2***************************************************
' File: autologonsetzen.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'*******************************************************
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SHOWINTASKBAR="no"
-->
<title>AutoLogon einschalten</title>
<HTA:APPLICATION ID="oHTA"
SCROLL="No"
SHOWINTASKBAR="yes"
NAVIGABLE="no"
APPLICATIONNAME="AutoLogon setzen"
>
<style type="text/css">
<!--
background:#02D020;
background:#1d2160;
background:#1d2160;
-->
<!--
html, body { font-Size:12pt; color:#E0C000; font-family:Verdana; /* font-weight:bold; */
background:#601010;
}
a { font-size:100%; color:#FFFFFF; text-decoration:underline; }
a:active { color:red; }
a:link { color:#FFE000; }
a:visited { color:#E0C000; }
a:hover { color:red; }
a:active { color:#E0C000; }
input, select, textarea
{ color:#1d2160; font-weight:bold; }
-->
</style>
</head>
<script language="VBscript">
Dim WSHNet : Set WSHNet = CreateObject("WScript.Network")
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
Dim DriveList : Set DriveList = CreateObject("Scripting.FileSystemObject").Drives
Const Titel = "autologonsetzen.hta"
Dim PCxxx : PCxxx = ""
Dim TastEing
Dim Tst, AbfrageStart
'****************************************
Sub HTASize()
'****************************************
' window.moveto Links, Oben
window.moveto 30, 30 ' Position
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 640, 480
End Sub
'**************************************************************
Sub StartAnzeige()
'**************************************************************
TastEing = 13
Dim Txt
Txt = Txt & " <Span style=""font-size:14pt""> "
Txt = Txt & " <fieldset><Legend align=""Center""> Für folgenden PC wird das AutoLogon gesetzt: </legend> "
Txt = Txt & " </Span><Span style=""font-size:10pt""> "
Txt = Txt & " <br> <input Type=""text"" Name=""PCxxx"" Value=""" & PCxxx & """ > "
Txt = Txt & " <br><br> "
Txt = Txt & " Primäres DNS-Suffix des Computers: "
Txt = Txt & " <br> <input Type=""text"" Name=""DNS"" Value=""" & "mein.zuhause.de"" > "
Txt = Txt & " <br><br> "
Txt = Txt & " Anmeldename (UserID) für das Autologon: "
Txt = Txt & " <br> <input Type=""text"" Name=""User"" Value=""" & "Users\dieseyer"" > "
Txt = Txt & " <br><br> "
Txt = Txt & " Passwort für den Anmeldenamen: "
Txt = Txt & " <br> <input Type=""Password"" Name=""Pwd"" Value=""SehrGeheim"" > "
Txt = Txt & " <br><br> "
Txt = Txt & " </fieldset></Span> "
Txt = Txt & " <br><br> "
Txt = Txt & " <INPUT TYPE=""button"" accesskey=""s"" onClick=""Eintragen()"" value=""aktivieren"" > oder "
Txt = Txt & " <input TYPE=""button"" accesskey=""r"" onClick=""Entfernen()"" value=""deaktivieren""> "
Txt = Txt & " <br><br> "
document.all.AnzeigeHTA.innerHTML = Txt
End Sub ' StartAnzeige()
'**************************************************************
Sub Entfernen
'**************************************************************
DNS = Document.All.DNS.Value
PCxxx = UCase( Document.All.PCxxx.Value ) & "." & DNS
' MsgBox PCxxx & vbCRLF & User & vbCRLF & Pwd, , "115 :: " & Titel
If not WMIpingOK( PCxxx ) Then
MsgBox """" & PCxxx & """ ist nicht erreichbar", , "118 :: " & Titel
Else
Const HKEY_LOCAL_MACHINE = &H80000002
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCxxx & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "AutoAdminLogon"
strValue = 0
' MsgBox "strValue-AutoAdminLogon: " & strValue, , "127 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultPassword"
strValue = ""
' MsgBox "strValue-Pwd: " & strValue, , "133 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
Set oReg=nothing
MsgBox PCxxx & vbCRLF & vbCRLF & "ist nicht (mehr) auf AutoLogon gesetzt.", , "138 :: " & Titel
End If
End Sub ' Entfernen
'**************************************************************
Sub Eintragen
'**************************************************************
DNS = Document.All.DNS.Value
PCxxx = UCase( Document.All.PCxxx.Value ) & "." & DNS
User = UCase( Document.All.User.Value )
Pwd = Document.All.Pwd.Value
' MsgBox PCxxx & vbCRLF & User & vbCRLF & Pwd, , "152 :: " & Titel
If not WMIpingOK( PCxxx ) Then
MsgBox """" & PCxxx & """ ist nicht erreichbar", , "155 :: " & Titel
Else
Const HKEY_LOCAL_MACHINE = &H80000002
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCxxx & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "AutoAdminLogon"
strValue = 1
' MsgBox "strValue-AutoAdminLogon: " & strValue, , "165 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultUserName"
strValue = Mid( User, InStr( User, "\" ) + 1 )
' MsgBox "strValue-User: " & strValue, , "171 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultDomainName"
strValue = Left( User, InStr( User, "\" ) - 1 )
' MsgBox "strValue-DefaultDomainName: " & strValue, , "177 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultPassword"
strValue = Pwd
' MsgBox "strValue-Pwd: " & strValue, , "183 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
Set oReg=nothing
MsgBox PCxxx & vbCRLF & vbCRLF & "erfolgreich auf AutoLogon gesetzt.", , "188 :: " & Titel
End If
End Sub ' Eintragen
'**************************************************************
Function WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
' Aufruf z.B.: If not WMIpingOK( ZielPC ) Then MsgBox ZielPC & " ist nicht erreichbar." : WScript.Quit
Dim objPing, objStatus
WMIpingOK = True
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & PCName & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
' WScript.Echo("machine " & machine & " is not reachable")
WMIpingOK = False
End If
Next
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
Function BeimLaden() ' ruft einige Routinen auf
'**************************************************************
call HTASize
' PCxxx = document.parentwindow.clipboardData.GetData("text")
call StartAnzeige()
End Function ' BeimLaden
'**************************************************************
Sub document_onKeyDown
'**************************************************************
If window.event.keyCode = 13 AND TastEing = 13 Then Call Eintragen()
End Sub
'----------------------------------------
</script>
<body onLoad="BeimLaden()" style="background-image:url(winpe.jpg)" >
<form >
<h2 align="center">www.dieseyer.de - autologonsetzen.hta</h2>
<table border="0" cellspacing="20px" width="0100%">
<tr >
<td align="Center" cellspacing="70%" >
<div ID=AnzeigeHTA >
</td>
</tr>
</table>
</form>
</body>
#########################################################################
>>> autostart-run.vbs <<<
'v4.4***************************************************
' File: autostart-run.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm listet die RegKeys, die Auto-Start / Auto-Run
' veranlasst
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WshShell, WSHNet, fso, ObjReg, ObjRemote, KeyX, Text, RootKey, oVal, FileOut, PC ' , FileIn ', Datei
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?"
PC = wshnet.ComputerName
PC = "MeinPC"
PC = InputBox (Text, WScript.ScriptName, PC )
If PC = "" then PC = wshnet.ComputerName
' Set FileOut = fso.OpenTextFile( PC & ".txt" , 8, true) ' alte Datei fortsetzen
Set FileOut = fso.OpenTextFile( PC & ".txt" , 2, true) ' neue Datei
FileOut.WriteLine now() & " ===> " & PC
' Set ObjRemote = objReg.RemoteRegistry(wshnet.ComputerName) ' Objekt zeigt auf aktuellen PC (REGOBJ.DLL)
Set ObjRemote = objReg.RemoteRegistry( PC ) ' Objekt zeigt auf (Remote-) PC (REGOBJ.DLL)
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServices
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce
' HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows
Text = "*** startet vor Kennwortabfrage - nachdem graphische Benutzeroberfläche erschienen ist "
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run"
RegKeysRead KeyX, vbCRLF & Text
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices"
RegKeysRead KeyX, ""
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services"
RegKeysRead KeyX, ""
FileOut.WriteLine
FileOut.WriteLine
Text = "*** startet nach der Kennwortabfrage / nach der Anmeldung "
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run"
RegKeysRead KeyX, vbCRLF & Text
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServices"
RegKeysRead KeyX, ""
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows"
FileOut.WriteLine
FileOut.WriteLine KeyX
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
If InStr( UCase( oVal.Name ), "LOAD") Then FileOut.WriteLine ( " " & oVal.Name & vbTab & " ==> " & vbTab & oVal.Value)
' If InStr( UCase( oVal.Name ), "DEVICE") Then FileOut.WriteLine ( " " & oVal.Name & vbTab & " ==> " & vbTab & oVal.Value)
If InStr( UCase( oVal.Name ), "RUN" ) Then FileOut.WriteLine ( " " & oVal.Name & vbTab & " ==> " & vbTab & oVal.Value)
Next
Set RootKey = nothing
On Error GoTo 0
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
' c:\winnt\winstart.bat
If UCase( wshnet.ComputerName ) = UCase( PC )then
INIread "c:\winnt\win.ini"
INIread "c:\winnt\System.ini"
WinStart "c:\winnt\winstart.bat"
Else
If fso.FileExists( "\\" & PC & "\c$\winnt\win.ini" ) Then
INIread "\\" & PC & "\c$\winnt\win.ini"
INIread "\\" & PC & "\c$\winnt\System.ini"
WinStart "\\" & PC & "\c$\winnt\winstart.bat"
Else
FileOut.WriteLine
FileOut.WriteLine
FileOut.WriteLine "\\" & PC & "\c$\winnt\win.ini - nicht erreichbar"
FileOut.WriteLine "\\" & PC & "\c$\winnt\System.ini - nicht erreichbar"
FileOut.WriteLine "\\" & PC & "\c$\winnt\winstart.bat - nicht erreichbar"
End If
End If
FileOut.WriteLine
FileOut.WriteLine
FileOut.WriteLine now() & " ===> " & PC
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
WSHShell.Run ( PC & ".txt" )
WScript.Quit
'**************************************************************
Sub RegKeysRead ( KeyX, Text )
'**************************************************************
FileOut.WriteLine Text
FileOut.WriteLine KeyX
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
FileOut.WriteLine ( " ==>|" & oVal.Value & "|<==" )
Next
Set RootKey = nothing
On Error GoTo 0
End Sub ' RegKeysRead ( KeyX, Text )
'**************************************************************
'**************************************************************
Sub INIread ( Datei )
'**************************************************************
Dim i, FileIn
FileOut.WriteLine
if not fso.FileExists( Datei ) Then
FileOut.WriteLine " " & Datei & " ==> existiert nicht!!!"
Else
FileOut.WriteLine "*** " & Datei & " - Infos:"
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' 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
If Instr( UCase( Zeile(i) ), "RUN=" ) Then FileOut.WriteLine Zeile(i)
If Instr( UCase( Zeile(i) ), "LOAD=") Then FileOut.WriteLine Zeile(i)
' If Instr( UCase( Zeile(i) ), "AIFC=") Then FileOut.WriteLine Zeile(i)
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
End If
End Sub ' INIread ( Datei )
'**************************************************************
'**************************************************************
Sub WinStart ( Datei )
'**************************************************************
Dim i, FileIn
FileOut.WriteLine
if not fso.FileExists( Datei ) Then
FileOut.WriteLine " " & Datei & " ==> existiert nicht!!!"
Else
FileOut.WriteLine "*** " & Datei & " - Infos:"
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' 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
FileOut.WriteLine Zeile(i)
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
End If
End Sub ' WinStart ( Datei )
'**************************************************************
#########################################################################
>>> autostart-run2.vbs <<<
'v5.5***********************************************************
' File: autostart-run2.vbs
' Autor: "LICHTER"
' dieseyer.de
'
'Das folgende Programm soll
'Einträge im AutoStartVerzeichnis anzeigen
'kritische Reg-Schlüssel
' auslesen,
' speichern und
' beim nächsten Programmaufruf vergleichen und
' hinzugekommene Einträge melden.
'
' http://source-center.de/forum/showthread.php?t=9502
'***************************************************************
' Reg-Schlüssel löschen
Dim Arr(20)
DIM sch(40)
tit = "Mörfi's Reg_Viewer 0.1 für WIN2000 und höher (05/2005 BA Pankow)"
set WshShell = WScript.CreateObject("WScript.Shell")
ordner = WshShell.SpecialFolders("AllUsersStartup")
Set fso = CreateObject("Scripting.FileSystemObject")
on error resume next
Set f = fso.GetFolder(ordner)
set fc = f.Files
x ="Über den Autostartordner werden gestartet:" & vbcrlf & vbcrlf
for each item in fc
x = x & item.name & " -> " & " erstellt am: "& item.DateCreated & vbCrlf
next
ordner = WshShell.SpecialFolders("Startup")
Set f = fso.GetFolder(ordner)
set fc = f.Files
for each item in fc
x = x & item.name & " -> " & " erstellt am: "& item.DateCreated & vbCrlf
next
WshShell.PopUp x & vbcrlf & vbcrlf & "REG-Schlüssel wird gelesen. Moment bitte ....",3, tit, vbExclamation
xx = 0
Arr(1) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(2) = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(3) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnceEx\"
Arr(4) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices\"
Arr(5) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce\"
Arr(6) = "HKEY_USERS\S-1-5-18\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(7) = "HKEY_USERS\.DEFAULT\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(8) = "HKEY_USERS\.DEFAULT\Software\Microsoft\Windows\CurrentVersion\RunOnce\"
Arr(9) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(10) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunOnce\"
Arr(11) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunServices\"
Arr(12) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunOnceEx\"
Arr(13) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce\"
Arr(14) = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce\"
Arr(15) = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnceEx\"
dat1 = "c:\datx1.tmp "
dat = "c:\da.tmp "
dat2 = "c:\datref.tmp"
datref = ""
if fso.fileexists(dat2) then
set a = fso.opentextfile(dat2)
while not a.atendofStream
datref = datref & a.Readline
wend
a.close
end if
iText = "Über die Registry werden mindestens gestartet:" & " (15 Schlüssel wurden ausgewertet)" & vbcrlf & "***** NAME und Pfad ******" & vbcr
TextX = ""
daten1=""
z2 = 0
for g = 1 to 15
schluss = arr(g)
WshShell.Run "regedit /E " & dat1 & schluss,0,true
rs = " type " & dat1 & " > c:\da.tmp"
yyy = WshShell.Run ("cmd /C " & rs,0,true)
if not fso.FileExists(Dat) then
msgbox "Schlüssel : " & schluss & " nicht gefunden. Programm wird abgebrochen", vbExclamation, tit
wscript.quit
end if
Set FinList = FSO.OpenTextFile( trim(Dat), 1 )
TextX = FinList.Readline
extX = FinList.Readline
TextX = FinList.Readline
if textx = "["& schluss &"]" then
Do While Not (FinList.atEndOfStream)
TextX = FinList.Readline
If not Left ( TextX, 1 ) = "[" then
TextX = Replace(TextX, chr(34), "")
TextX = Replace(TextX, "\\", "\")
i1 = Instr(1, TextX,"=", 1)
if i1 > 0 then
wert = Left(TextX, i1 - 1)
daten = right(TextX, len(TextX)-i1)
else
exit do
end if
xx = xx +1
sch(xx) = schluss & wert ' für spätere Löschung
itext = itext & xx & ". ("&g&")"&vbtab & Ucase(wert) & " --> " & Lcase(daten) & vbcrlf
if fso.fileexists(dat2) then
z1 = instr(datref,daten)
if z1 = 0 then
msgbox "Achtung neuer Registry-Eintrag: " & vbcrlf & Ucase(wert) & " --> " & daten,16,tit
z2 = z2 +1
end if
end if
daten1 = daten1 & daten & vbcrlf
end if
Loop
end if
Set FinList = nothing
next
fso.DeleteFile(dat)
fso.DeleteFile(dat1)
if not fso.fileexists(dat2) then
WshShell.PopUp "Referenz-Datei " & vbcrlf & vbcrlf & Ucase(dat2) & vbcrlf & vbcrlf &"wird angelegt." & "Sollen neue Registry-Einträge legitimiert werden, dann die Referenz-Datei löschen.", 15, tit, vbExclamation
set a = fso.createtextfile(Ucase(dat2),true)
set a = fso.opentextfile(dat2,8,true)
a.write daten1
a.close
end if
itext2 =""
if z2 <> 0 then itext2 = "Alle neuen Einträge legitimieren? Wenn ja, dann Datei " & Ucase(dat2) & " löschen." & vbcrlf
itext = itext & vbcrlf & vbcrlf & itext2 & "Ein Programm davon löschen? Vorsicht geboten! Ggf. läßt sich WINDOWS nicht mehr starten"
ant = wshshell.PopUp (itext , , tit,260) ', vbExclamation
if ant = 6 then
antx = 100
do while antx > xx
antx = 100
antx = EingabeZahl("Daten-Werte-Paar löschen" & vbcrlf & "Nr. des Datensatzes eingeben:" & vbcrlf & "(0 = Abbruch)" & vbcrlf & "")*1
if antx = 0 then wscript.quit
loop
msgbox sch(antx)
antxx = sch(antx)
wshShell.RegDelete antxx
end if
Private Function EingabeZahl(Text1)
Dim ix
ix = "Zahl eingeben"
do until isnumeric(ix)
ix = Inputbox(Text1, tit ,"Zahl eingeben")
if not isnumeric(ix) then ix = "Bitte gültige Zahl eingeben"
loop
EingabeZahl = ix
End Function
#########################################################################
>>> autostart.vbs <<<
'*** v9.6 *** www.dieseyer.de ******************************
Set Fso = WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss = WScript.CreateObject ( "WScript.Shell" )
'
' Datei: autostart.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' AutoStart( PC )
' gibt ein Array zurück, in dem alle Autostarteinträge
' gelistet sind. Jedes Array-Element enthält folgende,
' durch Tabulator getrennte Informationen:
' Command Befehl, .exe
' Description Beschreibung, Name
' Location z.B. Eintrag im AutoStart-Ordner
' oder Registry-Schlüssel
' Name häufig identisch mit Description
' User z.B. 'All Users', '.DEFAULT'
' 'NT-AUTORITÄT\SYSTEM'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim ZwArray : ZwArray = AutoStart( "." )
MsgBox "Es gibt " & UBound( ZwArray ) + 1 & " Autostart-Einträge.", , "025 :: " & WScript.ScriptName
Call ArrayZeigen( ZwArray )
WScript.Quit
'*** v9.6 *** www.dieseyer.de ******************************
Function AutoStart( PC )
'***********************************************************
' Hey, Scripting Guy!
' How Can I List All the Items in the Run Key in the Registry?
' http://www.microsoft.com/technet/scriptcenter/resources/qanda/feb06/hey0220.mspx
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & PC & "\root\cimv2")
Dim colStartupCommands : Set colStartupCommands = objWMIService.ExecQuery("Select * from Win32_StartupCommand")
Dim t, i
i = 0
t = "Nr." & vbTab & ".Command" & vbTab & ".Description" & vbTab & "Location" & vbTab & ".Name" & vbTab & ".User" & vbCRLF
Dim objStartupCommand
For Each objStartupCommand in colStartupCommands
t = t & i + 1 & vbTab & objStartupCommand.Command & vbTab & objStartupCommand.Description & vbTab & objStartupCommand.Location & vbTab & objStartupCommand.Name & vbTab & objStartupCommand.User & vbCRLF
ReDim Preserve AutoStartListe(i)
AutoStartListe(i) = objStartupCommand.Command & vbTab & objStartupCommand.Description & vbTab & objStartupCommand.Location & vbTab & objStartupCommand.Name & vbTab & objStartupCommand.User
i = i + 1
' Wscript.Echo "Command: " & objStartupCommand.Command
' Wscript.Echo "Description: " & objStartupCommand.Description
' Wscript.Echo "Location: " & objStartupCommand.Location
' Wscript.Echo "Name: " & objStartupCommand.Name
' Wscript.Echo "User: " & objStartupCommand.User
Next
' ArrayZeigen( AutoStartListe )
' MsgBox t, , "060 :: " & WScript.ScriptName
' WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( WScript.ScriptFullName & ".csv", 2, true ).WriteLine ( t )
AutoStart = AutoStartListe
End Function ' AutoStart()
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
' LogEintrag "114 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "115 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> bilddatumordner.vbs <<<
' ******************************************************
' Copyright: W.Schmelz, 28.11.2006
' ******************************************************
'Datum der Bilder eines gleich zu bestimmenden Ordners suchen, Ordner
'entsprechend dem Datum schreiben mit max. 4 wählbaren Unter-Ordnern:
'Ich habe vorgeschlagen: " Original ", " Zwischen ", " Bearbeitung ".
'Ankündigung des Programmes, Unterordner und Bildordner abfragen :
Titel=" Bilder in Datums - Ordner verschieben"
X=VbCR&VbCR
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Ask=MsgBox (X&VbCR&_
" Einsortieren von Origial-Bildern in Datums-Ordner !"&X&VbCR&_
"Das Datum der Bild - Dateien eines Ordners wird gesucht,"&X&_
"Ordner werden dem Datum entsprechend angelegt, z. B.,"&X&_
""" 18.12.05 "", und in diesem Ordner z. B. die Unterordner :"&X&_
""" Original "", "" Zwischen "", "" Bearbeitung "" . Die Bild-Dateien"&X&_
"werden zum Datum in dessen 1. Unter - Ordner verschoben "&X&_
VbCR&"Diese Vorgangsweise lohnt sich nur bei sehr vielen Bildern !"&_
X&VbCR,4+64+0,Titel)
If Ask=7 then WScript.Quit ' Abbruch, wenn "Nein"("7")
Eingabe=InputBox (X&VbCR&_
"Ich schlage als Unterordner der Datums-Ordner"&X&_
"vor: ""Original"", ""Zwischen"", ""Bearbeitung"". Die"&X&_
"Bild-Dateien werden in den ersten Unter-Ordner"&X&_
"des Datums-Ordner verschoben, hier ""Original""!"&X&_
"Es sind höchstens 4 Unter-Ordner möglich und"&X&_
"diese sind mit dem Zeichen "" # "" zu trennen !"&X&VbCR&_
VbCR,Titel,"Original#Zwischen#Bearbtng")
If Eingabe="" then WScript.Quit ' Abbruch, wenn "Cancel"("")
'Eingabe überprüfen:
Fehler="0"
If Left(Eingabe,1)="#" or Right(Eingabe,1)="#" then Fehler=1
y=1 'Leerstelle vorhanden?
Do until y>Len(Eingabe)
If Mid(Eingabe,y,1)=" " then Fehler=1
y=y+1
Loop
If Fehler=1 then MsgBox X&X&_
" Die Unterordner wurden falsch eingegeben "&_
X&X,VbCritical,Titel:WScript.Quit
'Eingabe aufspalten in max. 4 Teile:
ReDim Preserve Name(4)
Name(1)="0"
Name(2)="0"
Name(3)="0"
Name(4)="0"
'Aufspaltung in Ort( )
Ort=Split(Eingabe,"#")
'Vorhandene Eingaben auswählen
ReDim Preserve Ort(4)
If not Ort(0)="" then Name(1)=Ort(0)
If not Ort(1)="" then Name(2)=Ort(1)
If not Ort(2)="" then Name(3)=Ort(2)
If not Ort(3)="" then Name(4)=Ort(3)
'Eingaben zur Sicherheit melden
Meld1=Name(1)
Meld2=Name(2)
Meld3=Name(3)
Meld4=Name(4)
If Meld2="0" then Meld2=""
If Meld3="0" then Meld3=""
If Meld4="0" then Meld4=""
MsgBox X&X&VbTab&_
"Es werden folgende Unter - Ordner angelegt : "&_
X&VbCR&VbTab&Meld1&X&VbTab&Meld2&X&VbTab&Meld3&X&VbTab&_
Meld4&X&VbCR,," Unterordner bilden !"
'Den gewünschten Bild - Ordner festlegen:
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder(0,StrPrompt,BrowseInfo,Root)
On Error Resume Next
Err.Clear
Pfad=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
'Dateien des Ordners festlegen und anschließend das Datum
'der Bild-Dateien "File" im ausgesuchten Ordner ermitteln:
Set Data=Fso.GetFolder(Pfad).Files
'Bearbeitungsschleife starten:
'Betrachtung aller Dateien des oben ausgesuchten Ordners :
For each File in Data ' < -----------
'Das Datum steht an den ersten 10 Stellen, werden 7. und 8. gestrichen,
'so wird aus " 18.12.2005 " damit " 18.12.05 "
Ordner=Left(File.DateLastModified,6)&Mid(File.DateLastModified,9,2)
Ordner=Pfad&"\"&Ordner
'Datei - Endung suchen und nur die Bilder weiter betrachten:
Ext=LCase(Right(File,3))
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
'( Endg ist "false" oder "true" )
'Nur wenn die Dateien Bilder sind, werden Ordner gemäß ihrem Datum
'angelegt, samt den gewünschten Unterordnern:
If Endg and not Fso.FolderExists(Ordner) then
Set Dat=Fso.CreateFolder(Ordner)
If not Name(1)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(1))
If not Name(2)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(2))
If not Name(3)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(3))
If not Name(4)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(4))
End If
'Es werden nur Bilder in Ordner&"\"&"Original" bzw. Name(1) geschoben:
If Endg then Fso.MoveFile File,Ordner&"\"&Name(1)&"\"
Next ' < -----------
'Schluss - Meldung:
MsgBox X&X&VbTab&_
"Die Bild - Dateien des ausgesuchten Ordners wurden in "&_
X&VbTab&"die Ordner geschrieben, die dem Bild-Datum entsprechen!"&X&X,,Titel
#########################################################################
>>> bildnummeriersortier.vbs <<<
'*** v9.3 *** www.dieseyer.de *******************************
' File: BildNummerierSortier..vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Datei: "BildNummerierSortier."&"v"&"b"&""&""&""s"
'* *
'* " Ms"&"H"&"t"&"a.exe / XYZ."&"v"&"b"&""&""&"s" / V"&"b"&"Script " *
'* Solche oft skurrile Schreibweise soll den Virenscanner beruhigen ! *
'* - Hin und Her zwischen V-b-s und H-t-a beunruhigt meinen Scanner ! *
'* Bilder eines Ordners benennen und/oder nummerieren oder wahlweise *
'* Original-Bilder zweier Ordner durch Benennung nach Datum und Zeit *
'* zeitlich passend ineinander sortieren und dann durch nummerieren ! *
'* Dabei sind pro Kamera 6 Bilder pro Sekunde als möglich eingeplant! *
'* Das müsste für eine Weile auch für schnellere Kameras ausreichen ! *
'* ( Meine Canon - SLR schaffte schon manchmal 2 Bilder pro Sekunde ) *
'* Auf Wunsch kann vor die endgültigen Nrn. ein Name gesetzt werden. *
'* Die Kameranamen können angehängt werden:"08_Alp377_C" wie "Canon". *
'* Bei einer Zeitverschiebung beider Kameras, ist die Zeit eingebbar! *
'* Einfach mit diesen beiden Kameras gleichzeitig ein Bild schießen ! *
'* Die Bilder werden im ausgesuchten Ordner gespeichert. Reicht der *
'* Platz aber nicht, wird gefragt, wohin sonst diese Bilder sollen ! *
'* Gesteuert wird das durch Vorweg-Eingaben in eine H-t-a - Datei,die *
'* durch zwei Klapptafeln den Fall, einen Ordner zu behandeln von dem *
'* zweiten trennt,Bilder zweier Ordner zeitlich passend zu sortieren. *
'* Diese Original - Ordner bleiben, daher ist keine Sicherung nötig ! *
'* *
'************************************************************************
' Alle Objekte und das Andere für dieses Programm zur Verfügung stellen :
' ***********************************************************************
Set Fso=WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss=WScript.CreateObject ("WScript.Shell")
Set Lwk=Fso.Drives
'Variable definieren, bei "Sub" - Programmen und "Function" sehr wichtig!
Dim Pfad1, Pfad2, Pfad3, Ziel, Name, xyz, Zahl, Zahl1, Zahl2, Bild(), Tag
Dim Sammel, Zeit(), Foto1, Monat, Jahr, Std, Min, Sek, Summe, Namen, Tag1
Dim Std1,Min1,Sek1, Foto, Anders, Foto2,Stelle, Folge, Numb, Wert1, Wert2
Titel=" Bilder benennen, nummerieren, sortieren !"
UV=VbCR&VbCR
Summe="0" 'Prüfen, wieviel Platz alle Bilder brauchen, s.u.
Datei1="C:\Temp\Vorfrage."&"h"&"t"&""&"a" 'Den Viren-Scanner beruhigen!
'*************************************************************************
'* *
If not Fso.FileExists (Datei1) then '*
'* ************************************* *
'* Nur beim allerersten Start dieses Folgende laufen lassen : *
'* Eine MsgBox zum Vorstellen aller Möglichkeiten dieses Programmes : *
'* *
'*************************************************************************
Msg=MsgBox ( UV&VbTab&"Bilder eines Ordner benennen "&_
"und / oder nummerieren !"&_
UV&VbTab&"( Dieser Ordner wird in einem Unterordner gesichert ! ) "&_
UV&VbTab&" . . . . . . oder . . . . . . "&_
UV&VbTab&"Das Programm sortiert auch originale Bilder"&_
" zweier Ordner "&UV&_
VbTab&"zeitlich passend ineinander, Datum und Zeit entsprechend!"&UV&_
VbTab&"Bei beiden Kameras sind bis zu 6 Bilder / Sek. eingeplant !"&UV&_
VbTab&"Bei einer Zeitverschiebung, ""frühere"" Kamera erst nennen !"&UV&_
VbTab&"Ggf. mit beiden Kameras eine Probeaufnahme anfertigen !"&UV&_
VbTab&"Alles wird im später ausgewählten Ordner gespeichert !"&UV&_
VbTab&"Wenn an der Stelle der Platz nicht reicht, wird informiert !"&_
UV&VbTab&"Die Original-Ordner bleiben, daher keine Sicherung nötig !"&_
UV, VbOkCancel, Titel)
If Msg="2" then WScript.Quit
End If
' **********************
'***********************************************************************
'* *
'* Folgende Datei ist hier vorweg eingearbeitet : *
'* ################################################ *
'* *
'* " Ms"&"H"&"t"&"a.exe / XYZ."&"v"&"b"&""&""&"s" / V"&"b"&"Script " *
'* Diese oft skurrile Schreibweise soll den Virenscanner beruhigen ! *
'* Hin und Her zwischen V-b-s und H-t-a beunruhigt meinen Scanner ! *
'* " H--t--a - Vorfrage . v--b--s " von W. Schmelz, 21.11.2008 *
'* Aus V--b--s - Datei eine H--t--a - Datei mit 3 Textfeldern und 2 *
'* Klick- Tasten zur Auswahl, samt Taste zum Abbrechen neu schaffen, *
'* aufrufen und die Einträge per Clipboard an V-b-s - Datei zurück ! *
'* Das geht natürlich auch in direkter Weitergabe mit den "Arg(i)" ! *
'* Hat aber auch den Nachteil, dass die Datei ein 2. Mal durchläuft! *
'* *
'***********************************************************************
Dim File, Text, Wort, Wort1, Wort2, Wort3, Kameras, Datei1
Set Fso=CreateObject ("Scripting.FileSystemObject")
Set Wss=CreateObject ("WScript.Shell")
If not Fso.FolderExists ("C:\Temp") then Fso.CreateFolder("C:\Temp")
Datei1="C:\Temp\Vorfrage."&"h"&"t"&"a"
If not Fso.FileExists (Datei1) then
' #####################################################
'
'**********************************************************************
'* *
'* Da bei Abholung der Eingaben aus Clipboard die V--b--s- Datei 2x ! *
'* durchlaufen wird, ist hier nur dieser erste Durchlauf ermöglicht ! *
'* Vor V--b--s - wird also H--t-a - Datei gesetzt, um gezielte Ein - *
'* gaben zu ermöglichen, die an die V--b--s - Datei zurück gehen !!! *
'* *
'**********************************************************************
Set File=Fso.CreateTextFile (Datei1, true)
Text=""&VbCR _
&"<Html>"&VbCR _
&"<Head>"&VbCR _
&"<Hta:Application"&VbCR _
&"Id=""Htaapp"""&VbCR _
&"Border=""5"""&VbCR _
&"Scroll=""No"""&VbCR _
&"SysMenu=""Yes"""&VbCR _
&"<Title>Vorgaben abfragen</Title>"&VbCR _
&"<Script Language=""VbScript"">"&VbCR _
&"Set Wss=CreateObject(""Wscript.Shell"")"&VbCR _
&"Set Fso=CreateObject(""Scripting.FileSystemObject"")"&VbCR _
&"Dat=""C:\Temp\Vorfrage.""&""h""&""t""&""a"" "&VbCR _
&"Dim Dat"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",""#"" "&VbCR _
&""&VbCR _
&"'************************************************************"&VbCR _
&"Sub Tafel1"&VbCR _
&"Window.ResizeTo 600,690 'Neue Breite und Höhe"&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ """&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&"" \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Green""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Bei einem Ordner bitte diese Angaben machen :"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Black""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Soll ein Name vor die nummerierten """&VbCR _
&"Txt=Txt&""Bilder gesetzt werden ?<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" bedeutet keiner ! """&VbCR _
&"Txt=Txt&""Bei """" 1 """" wird jedes """&VbCR _
&"Txt=Txt&""Bild nach dem Datum<br>"""&VbCR _
&"Txt=Txt&""benannt, um ggf. nachträglich """&VbCR _
&"Txt=Txt&""Bilder einfügen zu können ! <br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Namen"""" """&VbCR _
&"Txt=Txt&""Value=""""07_Palma"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Sollen die bisherigen Nummern erhalten bleiben - """&VbCR _
&"Txt=Txt&""oder soll<br>"""&VbCR _
&"Txt=Txt&""alles alphabetisch neu durchnummeriert """&VbCR _
&"Txt=Txt&""werden ?<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Radio"""" """&VbCR _
&"Txt=Txt&""Name=""""R2"""" ID=""""Opt1"""">"""&VbCR _
&"Txt=Txt&""Die alten Nummern sollen erhalten bleiben<br>"""&VbCR _
&"Txt=Txt&""<Input Checked Type=""""Radio"""" """&VbCR _
&"Txt=Txt&""Name=""""R2"""" ID=""""Opt2"""">"""&VbCR _
&"Txt=Txt&""Alles ist alphabetisch neu zu nummerieren<br>"""&VbCR _
&"Txt=Txt&""<br>"""&VbCR _
&"Txt=Txt&""Wenn nur ein bestimmter Teil """&VbCR _
&"Txt=Txt&""der Bilder behandelt werden<br>"""&VbCR _
&"Txt=Txt&""soll, so ist dieser zu kennzeichnen, """&VbCR _
&"Txt=Txt&""z.B. """" 533-677 """" !<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" , wenn keinerlei """&VbCR _
&"Txt=Txt&""Einschränkung sein soll !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Numb"""" """&VbCR _
&"Txt=Txt&""Value=""""0"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Input Type=""""Button"""" """&VbCR _
&"Txt=Txt&""Value=""""Mit diesen Eingaben das """&VbCR _
&"Txt=Txt&""Programm starten"""" Name=""""Information"""" """&VbCR _
&"Txt=Txt&""OnClick=Einer """&VbCR _
&"Txt=Txt&""Style=""""Background-Color:Green;Font-Size:11pt;"""&VbCR _
&"Txt=Txt&""Color:#CCCCCC;Width:270"""">"""&VbCR _
&"Txt=Txt&""</Center>"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Document.All.Info.InnerHTML=Txt"&VbCR _
&"Txt = """""&VbCR _
&"End Sub "&VbCR _
&"'***********************************"&VbCR _
&"Sub Tafel2"&VbCR _
&"Window.ResizeTo 600,690 'Neue Breite und Höhe"&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ """&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&"" \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&""<br><br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Blue""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Bei zwei Ordnern bitte folgende """&VbCR _
&"Txt=Txt&""Angaben machen :<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Black""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Welcher Name soll vor alle durchnummerierten<br>"""&VbCR _
&"Txt=Txt&""Bilder gesetzt werden ? """" 0 """" """&VbCR _
&"Txt=Txt&""bedeutet keiner !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Namen"""" """&VbCR _
&"Txt=Txt&""Value=""""08_Tuerk"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Sollen beide Kamera - Namen angehängt werden ?<br>"""&VbCR _
&"Txt=Txt&""Z.B. """" 08_Tuerk312_P.jpg """" """&VbCR _
&"Txt=Txt&""für """"P""""- anasonic,<br>"""&VbCR _
&"Txt=Txt&""""""C"""" für Canon. Bei """" 0 """" """&VbCR _
&"Txt=Txt&""keinen Anhang !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Kameras"""" """&VbCR _
&"Txt=Txt&""Value=""""PC"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Läuft die zweite Kamera in der Zeit voraus ?<br>"""&VbCR _
&"Txt=Txt&""Vorsprung in """"Tag:Std:Min:Sek"""" nennen !<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" bei keinem Zeitunterschied !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Anders"""" """&VbCR _
&"Txt=Txt&""Value=""""12:01:02:15"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Input Type=""""Button"""" """&VbCR _
&"Txt=Txt&""Value=""""Mit diesen Eingaben das """&VbCR _
&"Txt=Txt&""Programm starten"""" Name=""""Information"""" """&VbCR _
&"Txt=Txt&""OnClick=Zwei """&VbCR _
&"Txt=Txt&""Style=""""Background-Color:Blue;Font-Size:11pt;"""&VbCR _
&"Txt=Txt&""Color:#CCCCCC;Width:270"""">"""&VbCR _
&"Txt=Txt&""</Center>"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Document.All.Info.InnerHTML=Txt"&VbCR _
&"Txt = """""&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Sub Einer"&VbCR _
&"Ask=MsgBox (VbCR&VbCR&_"&VbCR _
&"""Wurden zu dem Ordner die richtigen Angaben gemacht ?""&_"&VbCR _
&""" ""&VbCR&VbCR&_"&VbCR _
&""" Wenn sicher , dann """" ""&_"&VbCR _
&"""Ja """" anklicken !""&_"&VbCR _
&"VbCR&VbCR,VbCritical+VbYesNo, _"&VbCR _
&""" Angaben zu einem Ordner"")"&VbCR _
&"If Ask=""7"" then Exit Sub"&VbCR _
&"Wort1=Namen.Value"&VbCR _
&"If Wort1="""" then Wort1=""0"""&VbCR _
&"If Document.All.Opt1.Checked then Wort2=""1"""&VbCR _
&"If Document.All.Opt2.Checked then Wort2=""2"""&VbCR _
&"Wort3=Numb.Value"&VbCR _
&"If Wort3="""" then Wort3=""0"""&VbCR _
&"If (Left(Wort1,1)="" "" or Left(Wort2,1)="" "" or _"&VbCR _
&"Left(Wort3,1)="" "") _"&VbCR _
&" then Fso.DeleteFile Dat "&VbCR _
&"If not Fso.FileExists (Dat) then Self.Close"&VbCR _
&"Wort=""1#""&Wort1&""#""&Wort2&""#""&Wort3"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",Wort"&VbCR _
&"Self.Close"&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Sub Zwei"&VbCR _
&"Ask=MsgBox (VbCR&VbCR&_"&VbCR _
&"""Wurden zu beiden Ordnern richtige Angaben gemacht ?""&_"&VbCR _
&""" ""&VbCR&VbCR&_"&VbCR _
&""" Wenn sicher , dann """" ""&_"&VbCR _
&"""Ja """" anklicken !""&_"&VbCR _
&"VbCR&VbCR,VbCritical+VbYesNo,_"&VbCR _
&""" Angaben zu den 2 Ordnern"")"&VbCR _
&"If Ask=""7"" then Exit Sub"&VbCR _
&"Wort1=Namen.Value"&VbCR _
&"If Wort1="""" then Wort1=""0"""&VbCR _
&"Wort2=Kameras.Value"&VbCR _
&"If Wort2="""" then Wort2=""0"""&VbCR _
&"Wort3=Anders.Value"&VbCR _
&"If Wort3="""" then Wort3=""0"""&VbCR _
&"If (Left(Wort1,1)="" "" or Left(Wort2,1)="" "" _"&VbCR _
&"or Left(Wort3,1)="" "") _"&VbCR _
&" then Fso.DeleteFile Dat "&VbCR _
&"If not Fso.FileExists (Dat) then Self.Close"&VbCR _
&"Wort=""2#""&Wort1&""#""&Wort2&""#""&Wort3"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",Wort"&VbCR _
&"Self.Close"&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Window.ResizeTo 600,250"&VbCR _
&"Window.MoveTo 200,50"&VbCR _
&"</Script>"&VbCR _
&"</Head>"&VbCR _
&"<Body BgColor=""#d3d3d3"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:14pt;Color:Black"">"&VbCR _
&"<br><br>"&VbCR _
&"<Center>"&VbCR _
&"<Input Type=""Button"" Name=""Ende"" "&VbCR _
&"Value=""Programm abbrechen"" _"&VbCR _
&"OnClick=""Self.Close"" Style=""Font-Family: "&VbCR _
&"Arial;Font-Size:14pt;Color:Red"">"&VbCR _
&"<br><br>"&VbCR _
&"<Input Type=""Button"" Name=""Ende"" "&VbCR _
&"Value=""Bilder eines Ordners nummerieren"""&VbCR _
&" OnClick=""Tafel1"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:13pt;Color:Green;Width:270"">"&VbCR _
&" <Input Type=""Button"" Name=""Start"" """""&VbCR _
&"Value=""Bilder zweier Ordner einsortieren"""&VbCR _
&" OnClick=""Tafel2"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:13pt;Color:Blue;Width:270"">"&VbCR _
&"<br><br>"&VbCR _
&"</Center>"&VbCR _
&"<Center><div Id=Einblenden></Center>"&VbCR _
&"<Center><div Id=Info></Center>"&VbCR _
&"</Body>"&VbCR _
&"</Html>"&VbCR _
&""&VbCR _
File.WriteLine(Text)
File.Close
' Die hier geschriebene H--t--a - Datei wird vornweg ans Laufen gebracht :
' *************************************************************************
Wss.Run Datei1, , true '"true" heißt: erst weiter, wenn beendet
End If
' ############################
' Bei Abbruch in Datei 1 ist an dieser Stelle abzubrechen :
' *********************************************************
If not Fso.FileExists (Datei1) then WScript.Quit
' " Wort ", d.h. die Ergebnisse der Voranfage, aus dem Clipboard abholen :
' ************************************************************************
Set Arg=WScript.Arguments
If Arg.Count=0 then
Board 'Subprogramm zur Abfrage des Zwischenspeichers
WScript.Quit
End If
Wort=Arg(0)
' *********************************************************************
Sub Board
Wss.Run "Ms"&"H"&"t"&"a.exe V"&"b"&"Script:"&_
"(CreateObject(""WScript.Shell"")."&_
"Run("""""""& WScript.ScriptFullName&""""" """""""&Chr(38)&_
"Document.ParentWindow.ClipboardData."&_
"GetData(""Text"")"&Chr(38)&"""""""""))(Window.Close)"
End Sub
' *********************************************************************
WScript.Sleep 500
If Fso.FileExists (Datei1) then Fso.DeleteFile Datei1
' Den Speicher zur Sicherheit gezielt mit neutralem Text überschreiben!
' *********************************************************************
Wss.Run "Ms"&"H"&"t"&"a.exe V"&"b"&"Script:"&_
"(Document.ParentWindow.ClipboardData."&_
"SetData(""Text"","""&" Ätsch ! ?"&"""))(Window.Close)"
If Wort="#" then WScript.Quit 'Wenn Fenster mit "X" geschlossen!
'Die Voreintragungen, das Wort1 bzw. Wort2 festlegen :
'*****************************************************
Wort1=""
Wort2=""
If Left(Wort,1)="1" then Wort1=Right(Wort,Len(Wort)-2)
If Left(Wort,1)="2" then Wort2=Right(Wort,Len(Wort)-2)
If Wort1<>"" then 'Ende s. Dateimitte
' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§
'Folgende ältere Datei ist in diesem Programm eingearbeitet :
' ***********************************************************
' * *
' * Dateiname : " BildName.v-b-s " *
' * *
' * Bildnamen im Ordner ändern, alte Nr. bleibt erhalten, *
' * - ggf. nur einen ausgewählten Bereich neu benennen! *
' * Oder alles (!) wird neu sortiert mit laufender Nr. ! *
' * Oder Originale werden nach Entstehungsdatum benannt- *
' * es sind bis zu 6 Bilder mit gleichem Datum möglich -, *
' * um sie in andere Gruppen zeitlich passend einzufügen! *
' * *
' * CopyRight: W. Schmelz 27.10.2008 *
' * *
' ***********************************************************
Set Fso = CreateObject ("Scripting.FileSystemObject")
'Dim UV, UVW, XX, NN, Pfad, Fso, Ttl, Zahl, Bild(), Weg
'Dim Zone, Anfg, Ende, Nrn()
' Neu bstimmen, damit keine Doppelfestlegungen :
' **********************************************
Dim UVW, XX, NN, Pfad, Titel, Weg, Zone, Anfg, Ende, Nrn()
' Ebenso sind viele Bezeichnungen dieser alten Datei zu ändern !
'***************************************************************
'Abkürzungen für die MsgBox
UV=VbCR&VbCR
UVW=UV&VbCR
XX=VbTab
Titel=" Bilddateien eines Ordners umbenennen !"
' Neu in dieser eingearbeiteten Datei sind :
'*******************************************
' Die Anfangs - Eingaben in alle deren Bestandteile unterteilen :
' ****************************************************************
Zahl=Split(Wort1,"#")
' Die Anfangs - Eingaben definieren u. genauestens kontrollieren :
' ****************************************************************
Namen=Zahl(0)
Folge=Zahl(1)
Numb=Zahl(2)
' Eine Kontrollmeldung aller der vorhin getätigten Vor-Auswahlen :
' ****************************************************************
Satz=Satz&UV&VbCR&"Folgende Angaben wurden bisher eingetragen"
Satz=Satz&VbCR&"*************************************"
If Namen="0" then _
Satz=Satz&UV&"Es wird kein Name vor diese Bilder gesetzt !"
If Namen="1" then _
Satz=Satz&UV&"Die Bilder werden nach dem Datum benannt !"&UV&VbCR
If Len(Namen)>=2 then
Satz=Satz&UV&"Vor alle Bilder kommt der gemeinsame Name :"
Satz=Satz&VbCR&Namen
End If
If Namen<>"1" then
Satz=Satz&UV&"Bei der Nummerierung der Bilder des Ordners"&VbCR
If Folge="1" then
Satz=Satz&"soll die bisherige Nummer des Bildes bleiben !"
else
Satz=Satz&"werden die Bilder alphabetisch nummeriert !"
End If
If Numb="0" then
Satz=Satz&UV&"Es werden alle Bilder des Ordners behandelt !"
Satz=Satz&UV&UV
else
Satz=Satz&UV&"Nur die Bilder "&Numb&" werden behandelt !"
Satz=Satz&UV&UV
End If
End If
Test=MsgBox ( Satz, VbInformation + VbOkCancel, Titel )
If Test="2" then WScript.Quit
' Den Bild - Ordner in einem Browser auswählen :
' **********************************************
Set Shl=CreateObject ( "Shell.Application" )
Set ObF=Shl.BrowseForFolder ( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad=ObF.Self.Path
If Err.Number>0 then WScript.Quit
Set All=Nothing
On Error GoTo 0 'Ignorieren der Fehler wieder aufheben !
Msg=MsgBox ( UV&VbCR&"Zur Behandlung wurde ausgewählt : "&Pfad&_
UV&VbCR, VbInformation + VbOkCancel, Titel )
If Msg="2" then WScript.Quit
' Jetzt folgt die Kette der benötigten Sub - Programm - Aufrufe :
' ***************************************************************
Wahlen
If Weg<>"1" then Sicher 'Alle Bilder sichern!
Sammeln 'Ist noch unsortiert!
If not Zone="" then Bereich
If Weg=1 then Pruef1 'Sichern erst danach !
Sortieren 'Die Bilder sortieren!
If Weg=2 then Pruef2
NeuName
' ************************************************************
' Es folgen jetzt alle die oben aufgerufenen Sub - Programme :
' ************************************************************
Sub Wahlen
' Der nun folgende Abschnitt wurde weitgehend umgearbeitet !
' **********************************************************
' Die Zahl der Bilder im Ordner prüfen :
' **************************************
Set FsF=Fso.GetFolder(Pfad)
Set FsFf=FsF.Files
Zahl="0"
For each File in FsFf
Zahl=1+Zahl
Next
If Zahl="0" then MsgBox UVW&_
" Dies Verzeichnis enthält keine Dateien !"&_
UVW, VbCritical, Titel : WScript.Quit
' Die Eingaben vom Anfang in dieses bestehende Programm einarbeiten :
' *******************************************************************
NN=Namen
If NN="" then WScript.Quit
If NN="0" then NN=""
If NN="1" then
Sicher 'Die Bilder sichern
Datum 'Umbenennung gemäß Datum durchführen!
End If
Weg=Folge 'Bezeichnungen umarbeiten !
If Weg="" then WScript.Quit
If NN="" then
If Weg="2" then Frg2=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
"Die Bilder werden nicht benannt, aber alphabet. nummeriert ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg2="7" then WScript.Quit
End If
If NN<>"" then
If Weg="2" then Frg2=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
"Bilder werden """&NN&""" genannt, alphabet. nummeriert ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg2="7" then WScript.Quit
End If
If Numb="0" then Numb=""
If Weg="1" then Zone=Numb
If Weg="1" and Zone<>"" then Teil="Einzelne "
If NN="" then
If Weg="1" then Frg4=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
Teil&"Die Bilder werden nicht benannt, aber die Nr. bleibt ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg4="7" then WScript.Quit
End If
If NN<>"" then
If Weg="1" then Frg4=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
Teil&"Bilder werden """&NN&""" genannt, die Nr. bleibt ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg4="7" then WScript.Quit
End If
If Weg="1" then 'Falls alte Nrn. bleiben sollen:
' Sind die vorhandenen Nummern mindestens 3 - stellig ?
' Gibt es Probleme in der Bezeichnung (08_0030_C.jpg) ?
' *****************************************************
Set Ort=Fso.GetFolder(Pfad).Files
For each File in Ort
Nr=Left(Right(File,7),3)
Z1=Left(Nr,1)
Z2=Mid(Nr,2,1)
Z3=Right(Nr,1)
If not (Asc(Z1)>47 and Asc(Z1)<58 and Asc(Z2)>47 and _
Asc(Z2)<58 and Asc(Z3)>47 and Asc(Z3)<58) then _
MsgBox UVW&" Fehler in der alten Nummerierung !"&_
UV&" Die Nr. sind nicht mind. 3 - stellig !"&_
UVW, VbCritical, Titel : WScript.Quit
Next
End If
End Sub
' ******************************************************************
Sub Sicher
' Alle Dateien im Ordner "Pfad" zählen, ihre Gesamtgröße ermitteln :
' ******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
Zahl="0"
For each i in Data
Zahl=1+Zahl
Summe=Summe+i.Size 'Summierung der Dateigrößen
Next
' Festplatte "X:\" analysieren, ob noch genug Platz, sonst Abbruch :
' ******************************************************************
Ziel=Left(Pfad,2) 'Die Ziel-Festplatte ermitteln
Set Lwrk=Fso.GetDrive(Ziel)
If Lwrk.FreeSpace<Summe+300000000 then '300 MB Rest lassen!
MsgBox UV&UV&"Das Speichermedium "&Ziel&"\ hat nicht genug"&_
UV&"Restanteil an Platz ! ! !"&UV&UV,VbCritical,Titel:WScript.Quit
End If
' Wenn dieser noch nicht vorhanden, einen Sicherungsordner anlegen :
' ******************************************************************
If not Fso.FolderExists (Pfad&"\Sicherng") then
Fso.CreateFolder(Pfad&"\Sicherng")
else
MsgBox UV&UV&" Es existiert bereits ein Sicherungsordner !?"&_
UV&UV, VbCritical, Titel : WScript.Quit
End If
' Alle Bilder des ausgesuchten Ordners werden jetzt gesichert :
' *************************************************************
Set Sich=Fso.GetFolder(Pfad)
Set Sichg=Sich.Files
For each File in Sichg
Fso.CopyFile File,Pfad&"\Sicherng\"
Next
' ********************************************************
' Die Kontrolle, ob die Sicherung korrekt angelegt wurde !
' Sonst der Abbruch, wenn die Ordner-Größen ungleich sind!
' ********************************************************
Set Folder1 = Fso. GetFolder ( Pfad ) 'Gesamtordner!
Set Folder2 = Fso. GetFolder ( Pfad & "\Sicherng\" )
Wert1 = Folder1.Size/2 ' " /2 " : Die Sicherung ist dabei!
Wert2 = Folder2.Size
If Wert1 <> Wert2 then
MsgBox UV & UV & _
"Die Sicherung ist nicht gelungen !" & UV & _
"So muss halt abgebrochen werden !" & UV & _
"Ggf. alles noch einmal versuchen !" & UV & _
UV, VbInformation, Titel
Fso.DeleteFolder ( Pfad & "\Sicherng" )
WScript.Quit
End If
End Sub
' ******************************************************************
Sub Datum
' Prüfen, ob nur Bild - Dateien enthalten, sonst kommt der Abbruch :
' ******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
For each i in Data
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung von i
If not (Endg="jpg" or Endg="tif" or Endg="raw") then
MsgBox UV&i&" ist keine Bild-Datei !!!"&UV, , Titel
WScript.Quit
End If
Next
' Auf die Sek. exaktes Datum der Original - Dateien "i" des Ordners :
' *******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
For each i in Data
Name=Left(i.DateLastModified,19) 'Datum der originalen Bilder i
'In "Name" Tag, Monat, Jahr, Std, Min, Sek finden:
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
'*****************************************************************
'* *
'* Bilder des Ordners benennen mit dem Namen gemäß der Zeit: *
'* Falls gleicher Zeit- Name schon da, an den neuen gleichen *
'* Namen "1" bis "5" anhängen, wird dann dahinter sortiert ! *
'* Es sind also 6 Bilder pro Sekunde dabei hier eingeplant ! *
'* *
'*****************************************************************
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung von i
Name=Pfad&"\"&Jahr&Monat&Tag&Std&Min&Sek 'ohne Datei- Endung
If not Fso.FileExists(Name&"."&Endg) then
Fso.MoveFile i,Name&"."&Endg
ElseIf (Fso.FileExists(Name&"."&Endg) and not _
Fso.FileExists(Name&"_1."&Endg)) then
Name=Name&"_1."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and not _
Fso.FileExists(Name&"_2."&Endg)) then
Name=Name&"_2."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and not _
Fso.FileExists(Name&"_3."&Endg)) then
Name=Name&"_3."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and _
Fso.FileExists(Name&"_3."&Endg) and not _
Fso.FileExists(Name&"_4."&Endg)) then
Name=Name&"_4."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and _
Fso.FileExists(Name&"_3."&Endg) and _
Fso.FileExists(Name&"_4."&Endg) and not _
Fso.FileExists(Name&"_5."&Endg)) then
Name=Name&"_5."&Endg
Fso.MoveFile i,Name
End If
Next
' Eine Schlussmeldung wird jetzt ausgegeben :
' *******************************************
MsgBox UV&XX&"Die Bilder sind nach dem Datum benannt !"&_
" "&UV, , Titel
WScript.Quit
End Sub
' *************************************************************
Sub Sammeln
' Die Bilder sammeln, nummeriert nach derem Eingang !
' ***************************************************
Set Ort=Fso.GetFolder(Pfad).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Ext=LCase(Right(File,3))
If Weg=1 then
Nr=Left(Right(File,8),4)
Z1=Left(Nr,1)
Z2=Mid(Nr,2,1)
Z3=Mid(Nr,3,1)
Z4=Right(Nr,1)
' Prüfen, ob mindestens vierstellige Nr. da sind :
' ************************************************
If not (Asc(Z1)>47 and Asc(Z1)<58 and Asc(Z2)>47 and _
Asc(Z2)<58 and Asc(Z3)>47 and Asc(Z3)<58 and Asc(Z4)>47 _
and Asc(Z4)<58) then Drei
'(Sub-Programm, das prüft, ob wenigstens dreistellige Nr.,
' und evtl. eine "0" ergänzt !)
End If
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
If Endg then Bild(i)=File
If not Endg then i=i-1
i=i+1
Next
Zahl=i-1
' Sind keine Bilder vorhanden ? !
' *******************************
If Zahl="0" then
MsgBox UV&UV&XX&_
"**********************************"&UV&_
XX&"Es ist kein Bild vorhanden !!! "&_
" "&UV&_
XX&"**********************************"&_
UVW, VbCritical, Titel : WScript.Quit
End If
If Zone="" then
Anfg="1"
Ende=Zahl
End If
End Sub
' *************************************************************
Sub Bereich
Lang=Len(Zone)
If Mid(Zone,2,1)="-" then
Anfg=Left(Zone,1)
Ende=Mid(Zone,3,Lang-2)
End If
If Mid(Zone,3,1)="-" then
Anfg=Left(Zone,2)
Ende=Mid(Zone,4,Lang-3)
End If
If Mid(Zone,4,1)="-" then
Anfg=Left(Zone,3)
Ende=Mid(Zone,5,Lang-4)
End If
End Sub
' *************************************************************
Sub Pruef1
' Ist eine Nr. etwa doppelt vorhanden ?
' *************************************
x=1
Do until x>Zahl
y=1
Do until y>Zahl
If Mid(Bild(y),Len(Bild(y))-7,4)=Mid(Bild(x),Len(Bild(x))-7,4) _
and x<>y then MsgBox UVW&_
" In Nummerierung war Nr. doppelt !"&_
UVW, VbCritical, Titel : WScript.Quit
y=y+1
Loop
x=x+1
Loop
Sicher
End Sub
' *************************************************************
Sub Sortieren
' Diese Bilder alphabetisch sortieren :
' *************************************
For i=1 to Zahl
For k=i+1 to Zahl
If Bild(i)>Bild(k) then
Y=Bild(i)
Bild(i)=Bild(k)
Bild(k)=Y
End if
Next
Next
End Sub
' *************************************************************
Sub Pruef2
' Ist der Name schon vorhanden ?
' ******************************
Lang=Len(NN)
Da="0"
x=1
Do until x>Zahl
If Left(Fso.GetFileName(Bild(x)),Lang)=NN then Da=1
x=x+1
Loop
If Da=0 then Exit Sub
' Sonst einen Hilfsnamen festlegen :
' **********************************
x=1
Do until x>Zahl
Ext=Lcase(Right(Bild(x),3))
Fso.MoveFile Bild(x),Pfad&"\"&"abc"&x&"."&Ext
Bild(x)=Pfad&"\"&"abc"&x&"."&Ext
x=x+1
Loop
End Sub
' *************************************************************
Sub Drei
' Die Bilder sammeln, nummeriert nach ihrem Eingang, und prüfen :
' ***************************************************************
Set Ort=Fso.GetFolder(Pfad).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Ext=LCase(Right(File,3))
' Den Ordnerinhalt auf Bilder prüfen :
' ************************************
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
If Endg then Bild(i)=File
If not Endg then i=i-1
i=i+1
Next
Zahl=i-1
' Sind keine Bilder vorhanden ? !
' *******************************
If Zahl="0" then
MsgBox UV&UV&XX&_
"**********************************"&UV&_
XX&"Es ist kein Bild vorhanden !!! "&_
" "&UV&_
XX&"**********************************"&_
UVW, VbCritical, Titel : WScript.Quit
End If
' Nrn. der Bilder 4 - stellig machen, Bild(i) neu definieren :
' ************************************************************
i=1
Do until i>Zahl
Z4=Left(Right(Bild(i),8),1)
If not (Asc(Z4)>47 and Asc(Z4)<58) then
Fso.MoveFile Bild(i), _
Left(Bild(i),Len(Bild(i))-7)&"0"&Right(Bild(i),7)
Bild(i)=Left(Bild(i),Len(Bild(i))-7)&"0"&Right(Bild(i),7)
End If
i=i+1
Loop
Sortieren 'Bilder mit 4 - stelligen Nrn. neu sortieren
' Neue Nrn(i) der Bilder ermitteln :
' **********************************
i=1
Do until i>Zahl
ReDim Preserve Nrn(i)
Nrn(i)=Left(Right(Bild(i),8),4)
i=i+1
Loop
' Den evtl. gewählten Bereich jetzt überprüfen :
' **********************************************
Ja="2"
If not Zone="" then
Bereich
Ja="0"
i=1
Do until i>Zahl
If CInt(Nrn(i))=CInt(Anfg) then
Ja=1+Ja
Anfg=i
End If
If CInt(Nrn(i))=CInt(Ende) then
Ja=1+Ja
Ende=i
End If
i=i+1
Loop
End If
If Ja<>2 then _
MsgBox UVW&" Der gewählte Bereich war ungeeignet !"&_
UVW, VbCritical, Titel : WScript.Quit
' Festlegungen, falls kein begrenzter Bereich gewählt wurde :
' ***********************************************************
If Zone="" then
Anfg="1"
Ende=Zahl
End If
' Die Bilder werden jetzt neu benannt :
' *************************************
i=1
Do until i>Zahl
Ext=LCase(Right(Bild(i),3))
If (i>CInt(Anfg)-1 and i<1+CInt(Ende)) then _
Fso.MoveFile Bild(i),Pfad&"\"&NN&Nrn(i)&"."&Ext
i=i+1
Loop
' Die Schlussmeldung wird jetzt ausgegeben :
' ******************************************
MsgBox UVW&XX&" Die Dateien wurden umbenannt !"&UVW, , Titel
WScript.Quit 'Abschalten, damit kein Übergang auf 2 Ordner
End Sub
' *************************************************************
Sub NeuName
' Den evtl. gewählten Bereich abstecken und dann überprüfen :
' ***********************************************************
Ja="2"
If not Zone="" then
Ja="0"
i=1
Do until i>Zahl
If CInt(Left(Right(Bild(i),8),4))=CInt(Anfg) then
Ja=1+Ja
Anfg=i
End If
If CInt(Left(Right(Bild(i),8),4))=CInt(Ende) then
Ja=1+Ja
Ende=i
End If
i=i+1
Loop
End If
If Ja<>2 then
MsgBox UVW&" Der gewählte Bereich war ungeeignet !"&_
UVW, VbCritical, Titel : WScript.Quit
End If
i=1
Do until i>Zahl
Ext=LCase(Right(Bild(i),3))
If Weg=1 then Nr=Left(Right(Bild(i),8),4)
If Weg=2 then
If i<10 then Nr="000"&i
If 9<i and i<100 then Nr="00"&i
If 99<i and i<1000 then Nr="0"&i
End If
If (i>CInt(Anfg)-1 and i<1+CInt(Ende)) then
Fso.MoveFile Bild(i),Pfad&"\"&NN&Nr&"."&Ext
End If
i=i+1
Loop
' Eine Schlussmeldung wird jetzt ausgegeben :
' *******************************************
MsgBox UVW&XX&" Die Dateien wurden umbenannt !"&UVW, , Titel
WScript.Quit 'Abschalten,damit kein Übergang auf 2. Ordner
End Sub
End If ' Ende vom 1. Programm
' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§
' Das 2. Programm, das die Bilder zweier Ordner zeitlich sortiert !
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
' Die Anfangs - Eingaben in alle einzelne Bestandteile unterteilen:
' *****************************************************************
Zahl=Split(Wort2,"#")
' Die Anfangs - Eingaben definieren und genauestens kontrollieren :
' *****************************************************************
Namen=Zahl(0)
Kameras=Zahl(1)
Anders=Zahl(2)
If Len(Kameras)>2 then MsgBox UV&_
"Die Kamera-Namen wurden falsch eingegeben !"&UV, _
VbCritical, Titel : WScript.Quit
' Die Kontrolle der eingebenen Zeitverschiebung, diese ist wichtig!
' *****************************************************************
If not Anders="0" then
Warnung=UV&UV&"Die Zeitverschiebung wurde falsch angegeben !"&UV&UV
Testen=""
For i=1 to Len(Anders) ' " : " in den Zeiten herausnehmen!
If Mid(Anders,i,1)=":" then
Testen=Testen&""
else
Testen=Testen&Mid(Anders,i,1)
End If
Next
' In der Zeit nur Zahlen enthalten und auch sonst alles sinnvoll ?
' ****************************************************************
For i=1 to Len(Testen)
If not (Asc(Mid(Testen,i,1))>=48 and Asc(Mid(Testen,i,1))<=57) _
then MsgBox Warnung, VbCritical, Titel : WScript.Quit
Next
If Left(Right(Anders,3),1)<>":" then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Right(Anders,2)>59 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If (Len(Anders)>=6 and Left(Right(Anders,6),1)<>":") then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)>=5 then _
If Left(Right(Anders,5),2)>59 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If (Len(Anders)>=9 and Left(Right(Anders,9),1)<>":") then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)>=8 then _
If Left(Right(Anders,8),2)>23 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Left(Anders,1)=":" then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)=11 and Left(Anders,2)>28 then _
MsgBox UV&UV&"Die Anzahl der Tage "&_
"ist zu groß gewählt worden !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Eine Kontrollmeldung aller der vorhin getätigten Vor-Auswahlen :
' ****************************************************************
Satz=Satz&UV&VbCR&"Folgende Angaben wurden bisher eingetragen"
Satz=Satz&VbCR&"*************************************"
Satz=Satz&UV&"Vor alle Bilder kommt der gemeinsame Name :"&VbCR
If Namen="0" then
Satz=Satz&"Es wird kein Name davor gesetzt !"
else
Satz=Satz&Namen
End If
Satz=Satz&UV&"Angehängte Kamera - Namen sollen werden:"&VbCR
If Kameras="0" then
Satz=Satz&"Der Kamera-Name wird nicht angehängt !"
else
Satz=Satz&""" "&Left(Kameras,1)&" "" für die 1., "" "
Satz=Satz&Right(Kameras,1)&" "" bei der 2. Kamera "
End If
Satz=Satz&UV&"Der Zeitvorsprung der 2. Kamera, der beim"&VbCR
Satz=Satz&"Sortieren berücksichtigt werden soll, beträgt:"&VbCR
Satz=Satz&Anders&" ( Tag : Std : Min : Sek )"&UV&UV
Test=MsgBox( Satz, VbInformation + VbOkCancel, Titel )
If Test="2" then WScript.Quit
' *******************************************************************
' Die MsgBox zum Vorstellen der weiteren Anfragen dieses Programmes :
' *******************************************************************
Msg=MsgBox (UV&VbCR&VbTab&"Bitte gleich zwei Ordner"&_
" mit den originalen Bildern "&UV&VbTab&_
"aussuchen, deren Bilder zeitlich passend ineinander"&UV&_
VbTab&"sortiert werden dem Aufnahmedatum entsprechend!"&UV&_
VbTab&"Bei Zeitverschiebung, ""frühere"" Kamera erst nennen!"&UV&_
VbTab&"Alles wird im später gewählten Ordner gespeichert !"&_
UV&VbTab&"Wenn dort der Platz nicht reicht, wird nachgefragt !"&_
UV&UV, VbOkCancel, Titel)
If Msg="2" then
If Fso.FileExists(Datei1) then Fso.DeleteFile Datei1
WScript.Quit
End If
' ****************************************************************
' * Den 1. Bild - Ordner jetzt in folgendem Browser aussuchen : *
' ****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den 1. Bildordner aussuchen !"&_
" "&_
UV&UV, 3, Titel, VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder ( 0, StrPrompt, BrowseInfo, Root)
On Error Resume Next
Err.Clear
Pfad1=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Alle Dateien in dem Ordner 1 zählen und danach durchprüfen :
' ************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
Zahl1="0"
Endg="0"
For each i in Data
Zahl1=1+Zahl1
Summe=Summe+i.Size 'Summierung der Dateigrößen
Ende=LCase(Right(i,3))
If not (Ende="jpg" or Ende="raw") then Endg="1"
Next
If Zahl1="0" then
MsgBox UV&UV&"Der Ordner "&Pfad1&" ist leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
If Endg="1" then
MsgBox UV&UV&"Der Ordner "&Pfad1&_
" enthält nicht nur Bilder !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'******************************************************************
'* Prüfen, ob im Ordner 1 mehr als 6 Bilder / Sek. vorliegen : *
'* Für diese Bilder die Zeit(k) = Tag&Std&Min&Sek feststellen ! *
'******************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
ReDim Preserve Zeit(Zahl1)
k=1 'Für die Zeit(k)
For each i in Data
Name=Left(i.DateLastModified,19)
Tag=Left(Name,2) 'Tag der Aufnahme ermitteln!
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2) 'Std der Aufnahme ermitteln!
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2) 'Sek der Aufnahme ermitteln!
Zeit(k)=Jahr&Monat&Tag&Std&Min&Sek
k=k+1
Next
' Alle diese "Zeit(k)" ihrem Datum gemäß untereinander sortieren :
' *****************************************************************
For i=1 to Zahl1
For k=i+1 to Zahl1
If Zeit(i)>Zeit(k) then
xyz=Zeit(i)
Zeit(i)=Zeit(k)
Zeit(k)=xyz
End if
Next
Next
' Kontrolle, wie oft die gleiche Zeit(k) und ggf. eine Warnmeldung :
' ******************************************************************
Sammel="1"
For i=1 to Zahl1
If i>1 then
If Zeit(i)=Zeit(i-1) then Sammel=Sammel+1
If Zeit(i)<>Zeit(i-1) then Sammel="1" 'Neuanfang
If Sammel>6 then
MsgBox UV&UV&_
"Im Ordner "" "&Pfad1&" "" sind mehr als 6 Bilder / Sek. !"&_
UV&"Eines dieser Kette ist Bild "&i&" !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
End If
Next
'****************************************************************
'* Den 2. Bild - Ordner jetzt in folgendem Browser aussuchen : *
'****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den 2. Bildordner aussuchen !"&_
" "&_
UV&UV, 3, Titel, VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad2=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Alle Dateien in dem Ordner 2 zählen und danach überprüfen :
' ***********************************************************
Set Data=Fso.GetFolder(Pfad2).Files
Zahl2="0"
Endg="0"
For each i in Data
Zahl2=1+Zahl2
Summe=Summe+i.Size 'Summierung der Dateigrößen
Ende=LCase(Right(i,3))
If not (Ende="jpg" or Ende="raw") then Endg="1"
Next
If Zahl2="0" then
MsgBox UV&UV&"Der Ordner "&Pfad2&" ist leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
If Endg="1" then
MsgBox UV&UV&"Der Ordner "&_
Pfad2&" enthält nicht nur Bilder !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Sind diese beiden Ordner 1 und 2 tatsächlich verschieden ?
' **********************************************************
If Pfad1=Pfad2 then
MsgBox UV&UV&_
"Es wurden nicht zwei verschiedene Ordner ausgewählt !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'******************************************************************
'* Prüfen, ob im Ordner 2 mehr als 6 Bilder / Sek. vorliegen : *
'* Für diese Bilder die Zeit(k) = Tag&Std&Min&Sek feststellen ! *
'******************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
ReDim Preserve Zeit(Zahl2)
k=1 'Für die Zeit(k)
For each i in Data
' ************************************
Name=Left(i.DateLastModified,19)
Tag=Left(Name,2) 'Tag der Aufnahme ermitteln!
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2) 'Sek der Aufnahme ermitteln!
Zeit(k)=Jahr&Monat&Tag&Std&Min&Sek
k=k+1
Next
' Alle diese "Zeit(k)" ihrem Datum gemäß untereinander sortieren :
' *****************************************************************
For i=1 to Zahl2
For k=i+1 to Zahl2
If Zeit(i)>Zeit(k) then
xyz=Zeit(i)
Zeit(i)=Zeit(k)
Zeit(k)=xyz
End if
Next
Next
' Eine Kontrolle, wie oft gleiche "Zeit(k)" und ggf. Warnmeldung :
' *****************************************************************
Sammel="1"
For i=1 to Zahl2
If i>1 then
If Zeit(i)=Zeit(i-1) then Sammel=Sammel+1
If Zeit(i)<>Zeit(i-1) then Sammel="1" 'Neuanfang
If Sammel>6 then
MsgBox UV&UV&_
"Im Ordner "" "&Pfad2&" "" sind mehr als 6 Bilder / Sek. !"&_
UV&"Eines dieser Kette ist Bild "&i&" !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
End If
Next
' ************************************
' Zum Abschluss einen Ziel- Ordner für sämtliche Bilder aussuchen :
' *****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den Zielordner der Bilder aussuchen !"&_
" "&_
UV&UV,3,Titel,VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad3=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Prüfen, ob der geplante Zielordner wirklich noch völlig leer ist:
' *****************************************************************
Set Data=Fso.GetFolder(Pfad3).Files
Zahl3="0"
For each i in Data
Zahl3=1+Zahl3
Next
If Zahl3>0 then
MsgBox UV&UV&"Der Ordner "&Pfad3&" ist nicht leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Prüfen, ob der Zielordner von beiden bisherigen verschieden ist :
' *****************************************************************
If (Pfad3=Pfad1 or Pfad3=Pfad2) then
MsgBox UV&UV&"Die Ordner sind leider nicht verschieden !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'*******************************************************************
'* Die Festplatte "X:\" analysieren, ob genügend Platz da, und *
'* Nachfrage, wenn die benannte Platte nicht genügend Platz hat: *
'*******************************************************************
Ziel=Left(Pfad3,2) 'Die Ziel-Festplatte ermitteln
For each k in Lwk
If k=Ziel then
If k.FreeSpace<Summe+300000000 then '300 MB Rest lassen !
Pfad3=InputBox ( UV&UV&"Das Speichermedium "&_
k&"\ hat nicht genug"&_
UV&"Restanteil an Platz ! ! Bestimmen Sie unten "&_
UV&"den Speicherplatz für sämtliche Bilder neu !"&UV&_
UV, Titel, "F:\Bilder\Gemixt" )
End If
End If
Next
' Eine Kontrollmeldung aller dieser getätigten Ordner - Auswahlen :
' *****************************************************************
Test=MsgBox(UV&"Folgende beiden Bild - Ordner :"&VbCR&Pfad1&_
VbCR&Pfad2&UV&"wurden zum Einsortieren ausgesucht !"&UV&_
"Erneut, aber durchsortiert finden sich die Bilder in:"&VBCR&_
Pfad3&UV&VbCR, VbOkCancel, Titel)
If Test="2" then WScript.Quit
' Sollen alle diese Bilder einen Namen vor deren Nrn. bekommen ?
' ****************************************************************
If Namen="0" then Namen="" 'Keinen Namen vorweg !
' An alle diese Bilder die " Namen " der beiden Kameras anhängen ?
' ****************************************************************
Foto=Kameras
Foto1=""
Foto2=""
If Foto<>"0" then Foto1=Left(Foto,1)
If Foto<>"0" then Foto2=Right(Foto,1)
If Foto="0" then Foto="" 'Keinen Namen anhängen !
' Bei Zeitverschiebung beider Kameras die Verschiebung bestimmen !
' ****************************************************************
If Anders<>"0" then
Tag1="00"
Std1="00"
Min1="00"
Sek1="00"
If Len(Anders)<=5 then
Stelle=InStr(Anders,":")
Min1=Left(Anders,Stelle-1)
Sek1=Right(Anders,2)
End If
If (Len(Anders)>6 and Len(Anders)<=8) then
Std1=Left(Anders,Len(Anders)-6)
Min1=Left(Right(Anders,5),2)
Sek1=Right(Anders,2)
End If
If Len(Anders)>9 then
Stelle=InStr(Anders,":")
Tag1=Left(Anders,Stelle-1)
Std1=Left(Right(Anders,8),2)
Min1=Left(Right(Anders,5),2)
Sek1=Right(Anders,2)
End If
End If
If Anders="0" then Anders="" 'Keine Verschiebung nötig !
' Die Frequenz der CPU ermitteln - wegen der Dauer des Programmes :
' *****************************************************************
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\0\~MHz"
Wert0=Wss.RegRead(CheckKey)
'Einen Doppel - Prozessor vorgefunden ?
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\1\~MHz"
Wert1=Wss.RegRead(CheckKey)
'Falls ein Doppel - Prozessor vorliegt :
If not Wert1="" then Wert0=Wert0*2
Zeit=Round((14*(Zahl1+Zahl2)/Wert0),1)
' Ein Hinweis auf eine überlange Dauer bei deutlich vielen Bildern :
' ******************************************************************
If Zahl1+Zahl2>150 then
Wss.Popup UV&UV&"Der Vorgang kann bei "&_
Zahl1+Zahl2&" Bildern ca. "&Zeit&" Min. dauern !"&_
" "&UV&UV, 4, Titel, VbCritical
End If
' Auf Sekunde exaktes Datei - Datum im Ordner 1 als Namen wählen :
'*****************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
For each i in Data 's.u. < ==============
Name=Left(i.DateLastModified,19)
' Tag, Monat, Jahr, Std, Min, Sek sämtlicher Aufnahmen ermitteln:
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
'******************************************************************
'* Falls Kamera 2 eine innere Systemzeit nach der Kamera 1 hat, *
'* müssen die Zeiten der Kamera 1 entsprechend durch Addition *
'* angeglichen werden : Sek, Min, Std, Tag, Monat, Jahr ändern! *
'******************************************************************
If Anders<>"" then
Sek=CInt(Sek)+CInt(Sek1) 'Ohne CInt: Anhängen statt Addition!
If Len(Sek)=1 then Sek="0"&Sek
If Sek>59 then
Sek=Sek-60
Min=Min+1
End If
If Len(Sek)=1 then Sek="0"&Sek
If Len(Min)=1 then Min="0"&Min
' ( Problem: "0" wurde bei Addition einfach weggelassen ! )
Min=CInt(Min)+CInt(Min1) 'Ohne CInt: Anhängen statt Addition!
If Len(Min)=1 then Min="0"&Min
If Min>59 then
Min=Min-60
Std=Std+1
End If
If Len(Min)=1 then Min="0"&Min
If Len(Std)=1 then Std="0"&Std
'( Problem: "0" wurde bei Addition einfach weggelassen ! )
Std=CInt(Std)+CInt(Std1) 'Ohne CInt: Anhängen statt Addition!
If Len(Std)=1 then Std="0"&Std
If Std>23 then
Do until Std<24
Std=Std-24
Tag=Tag+1
Loop
End If
If Len(Std)=1 then Std="0"&Std
If Len(Tag)=1 then Tag="0"&Tag
' ( Problem: "0" wurde bei Addition einfach weggelassen ! )
End If
Tag=CInt(Tag)+CInt(Tag1) 'Ohne CInt: Anhängen statt Addition!
If Len(Tag)=1 then Tag="0"&Tag
If Tag>31 and (Monat="01" or Monat="03" or Monat="05" or _
Monat="07" or Monat="08" or Monat="10" or Monat="12") then
Tag=Tag-31
Monat=CInt(Monat)+1
If Monat="13" then
Monat="01"
Jahr=CInt(Jahr)+1
If Len(Jahr)=1 then Jahr="0"&Jahr
End If
If Len(Tag)=1 then Tag="0"&Tag
If Len(Monat)=1 then Monat="0"&Monat
End If
If Tag>30 and (Monat="04" or Monat="06" _
or Monat="09" or Monat="11") then
Tag=Tag-30
Monat=CInt(Monat)+1
If Len(Tag)=1 then Tag="0"&Tag
If Len(Monat)=1 then Monat="0"&Monat
End If
If Tag>28 and (CInt(Jahr) mod 4<>"0") and Monat="02" then
Tag=Tag-28
Monat="03"
If Len(Tag)=1 then Tag="0"&Tag
End If
If Tag>29 and (CInt(Jahr) mod 4="0") and Monat="02" then
Tag=Tag-29
Monat="03"
If Len(Tag)=1 then Tag="0"&Tag
End If
Endg=LCase(Fso.GetExtensionName(i)) 'Datei - Endung
Name=Jahr&Monat&Tag&Std&Min&Sek&"_1."&Endg
'***************************************************************
'* Bilder des 1. Ordners kopieren mit Namen gemäß der Zeit : *
'* Falls gleicher Zeit- Name schon da, an den neuen gleichen *
'* Namen "1" bis "5" anhängen, wird dann dahinter sortiert ! *
'* Es sind also 6 Bilder pro Sekunde dabei hier eingeplant ! *
'***************************************************************
If not Fso.FileExists (Pfad3&"\"&Name) then
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"5_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"5_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
End If
Next 's.o. < ===============
' Auf Sekunde exaktes Datei - Datum im Ordner 2 als Namen wählen :
' ****************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
For each i in Data 's.u. < ============
Name = Left(i.DateLastModified,19)
' Tag, Monat, Jahr, Std, Min, Sek aller der Aufnahmen ermitteln :
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung
Name=Jahr&Monat&Tag&Std&Min&Sek&"_2."&Endg
' Die Bilder des 2. Ordners mit ihren Zeit - Namen hinzu kopieren :
' *****************************************************************
' Falls gleicher Zeit - Name da, an den gleichen Namen
' "A", "B" bis "E" anhängen, wird dahinter sortiert !
' Es sind also 6 Bilder pro Sekunde dabei eingeplant !
If not Fso.FileExists (Pfad3&"\"&Name) then
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"E_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"E_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
End If
Next 's.o. < ============
' Alle diese Bilder sammeln, sind vorerst nummeriert nach Auffinden :
' *******************************************************************
Set Ort=Fso.GetFolder(Pfad3).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Bild(i)=File
i=i+1
Next
Zahl=i-1
' Alle diese Bilder nach ihrem Datum und der inneren Zeit sortieren :
' *******************************************************************
For i=1 to Zahl
For k=i+1 to Zahl
If Bild(i)>Bild(k) then
xyz=Bild(i)
Bild(i)=Bild(k)
Bild(k)=xyz
End if
Next
Next
' Diese sortierten Bilder neu nummerieren, evtl. einen Namen davor :
' *******************************************************************
i=1
Do until i>Zahl
If i<10 then i="000"&i 'Nr. vierstellig machen
If (i>=10 and i<100) then i="00"&i
If (i>=100 and i<1000) then i="0"&i
If Right(Fso.GetBaseName(Bild(i)),2)="_1" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto1&Right(Bild(i),4)
If Right(Fso.GetBaseName(Bild(i)),2)="_2" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto2&Right(Bild(i),4)
If Foto="" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto2&Right(Bild(i),4)
i=i+1
Loop
' Schluss-Information, dass diese Einsortierung abgeschlossen wurde :
' *******************************************************************
Wss.Popup UV&UV&VbTab&" Das war es ! ! !"&_
" "&UV&UV, 10, Titel, VbInformation
WScript.Quit
#########################################################################
>>> browse-for-file-ie.vbs <<<
'*** v9.B *** www.dieseyer.de ******************************
'
' Datei: browse-for-file-ie.vbs
' Autor: Joseph Morales
' Auf: www.dieseyer.de
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' Unter Win7 / Windows 7 ist es ggf. erforderlich den
' 'Datei öffnen ...' Dialog in den Vordergrung zu holen
Call AppActivateVBS ( "Date" ) ' "Date" sind die ersten Zeichen im Fensternamen
MsgBox ChooseFile, , "016 :: " & WScript.ScriptName
WScript.Quit
'*** v6.B *** www.dieseyer.de ******************************
Function ChooseFile()
'***********************************************************
' aus http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_thread/thread/f00a1c5d856c731f/c1d22782d2816bff?lnk=st&q=Joseph+Morales+Here%27s+the+code+with+the+additions+to+make+things&rnum=1#c1d22782d2816bff
Dim IE : Set IE = CreateObject("InternetExplorer.Application")
ChooseFile = ""
IE.visible = False
IE.Navigate("about:blank")
Do Until IE.ReadyState = 4
' WScript.Sleep 33
Loop
IE.TheaterMode = False
IE.Document.Write "<HTML><BODY><INPUT ID=""Fil""Type=""file""></BODY></HTML>"
IE.height = "0"
IE.width = "0"
IE.visible = True
IE.visible = False
With IE.Document.all.Fil
.focus
.click
ChooseFile = .value
End With
IE.Quit
Set IE = Nothing
End Function 'ChooseFile()
'*** v9.4 *** www.dieseyer.de ******************************
Function UserTempVerz
'***********************************************************
' aus 'Scriptomatic v2.0' by 'The MS Scripting Guys'
Dim Tst
On Error Resume Next
err.Clear
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
MsgBox "Das lokale WMI ist defekt - der PC ist für WinTuC momentan nicht geeignet.", vbCritical + 4096, "062 :: " & Titel
SelfClose = "-NO" ' Unterdrückt die Aktualisierung
self.Close
Exit Function
End If
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Environment", "WQL", &h10 + &h20 )
Dim objItem
For Each objItem In colItems
If InStr( UCase( objItem.UserName ), UCase( CreateObject("WScript.Network").Username ) ) > 0 Then
' If objItem.SystemVariable = vbFalse Then UserTempVerz = objItem.VariableValue : Exit For
If InStr( UCase( objItem.VariableValue ), "TEMP" ) > 0 Then UserTempVerz = objItem.VariableValue : Exit For
If InStr( UCase( objItem.VariableValue ), "TMP" ) > 0 Then UserTempVerz = objItem.VariableValue : Exit For
End If
Next
' MsgBox UserTempVerz, , "077 :: "
If InStr( UCase( UserTempVerz ), "%USERPROFILE%" ) = 1 Then
UserTempVerz = Mid( UserTempVerz, Len( "%USERPROFILE%" ) + 1 )
UserTempVerz = CreateObject("WScript.Shell").Environment("PROCESS")("USERPROFILE") & UserTempVerz
End If
' MsgBox "UserTempVerz: " & UserTempVerz, , "083 :: " : WScript.Quit
End Function ' UserTempVerz
'*** v9.B *** www.dieseyer.de ******************************
Sub AppActivateVBS( ProgrName )
'***********************************************************
' Prozedur Schreibt ein VBS, das eine Anwendung in den
' Vordergrund holt
Dim ListeDatei, Txt, Datei
Datei = UserTempVerz() & "\" & CreateObject("Scripting.FileSystemObject").GetTempName()
Datei = Mid( Datei, 1, InStrRev( Datei, "." ) ) & "vbs"
' MsgBox Datei, , "096 :: "
Txt = ""
Txt = Txt & vbCRLF & "Do"
Txt = Txt & vbCRLF & "i = i + 1"
Txt = Txt & vbCRLF & "WScript.Sleep 33"
Txt = Txt & vbCRLF & "If CreateObject(""WScript.Shell"").AppActivate( ""Date"") Then Exit Do"
' Txt = Txt & vbCRLF & "WScript.Quit"
Txt = Txt & vbCRLF & "Loop"
' Txt = Txt & vbCRLF & "MsgBox i & ""xxxx"", ," & " ""104 :: "" "
CreateObject("Scripting.FileSystemObject").CreateTextFile( Datei ).Write Txt
CreateObject("WScript.Shell").Run "wscript.exe """ & Datei & """", , False
' CreateObject("WScript.Shell").Run "notepad """ & Datei & """", , False
End Sub ' AppActivateVBS( ProgrName )
#########################################################################
>>> browse-for-file.vbs <<<
'*** v6.C *** www.dieseyer.de ******************************
'
' Datei: browse-for-file.vbs
' Autor: ? ? ?
' Auf: www.dieseyer.de
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox BFF, , WScript.ScriptName
WSCript.Quit
'*** v9.B *** www.dieseyer.de ******************************
Function BFFStartVerzeichnis( Verz )
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
' unter Win7 / Windows 7 nicht verfügbar:
' http://technet.microsoft.com/en-us/magazine/2008.08.heyscriptingguy.aspx
' man nehme browse-for-file-ie.vbs
Dim Dialog : Set Dialog = CreateObject("UserAccounts.CommonDialog")
' Dialog.Filter = "Text Files|*.txt|All Files|*.*" ' zeigt nur *.txt
' Dialog.Filter = "Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*" ' zeigt nur *.xls
Dialog.Filter = "Alle Dateien|*.*" ' zeigt nur *.* - also ALLES
' Dialog.Filter = "Textdateien|*.txt|Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*"
Dialog.FilterIndex = 2 ' von den drei auswählbaren Filtern wird der 2. eingesetzt
Dialog.InitialDir = Verz
Dialog.ShowOpen
BFFStartVerzeichnis = Dialog.FileName
End Function ' BFFStartVerzeichnis( Verz )
'*** v6.C *** www.dieseyer.de ******************************
Function BFF()
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
Dim Dialog : Set Dialog = CreateObject("UserAccounts.CommonDialog")
' Dialog.Filter = "Text Files|*.txt|All Files|*.*" ' zeigt nur *.txt
' Dialog.Filter = "Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*" ' zeigt nur *.xls
Dialog.Filter = "Alle Dateien|*.*" ' zeigt nur *.* - also ALLES
' Dialog.Filter = "Textdateien|*.txt|Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*"
Dialog.FilterIndex = 2 ' von den drei auswählbaren Filtern wird der 2. eingesetzt
Dialog.ShowOpen
BFF = Dialog.FileName
End Function ' BFF()
#########################################################################
>>> browse-for-folder-1.vbs <<<
' http://www.source-center.de/forum/member.php?u=2469
strVerz = CreateObject( "Shell.Application" ).BrowseForFolder( 0, "Ordner auswählen", 22, 17 ).Items().Item().Path
MsgBox strVerz, , WScript.ScriptName
#########################################################################
>>> browse-for-folder.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' Datei: browse-for-folder.vbs
' Autor: ? ? ?
' Auf: www.dieseyer.de
'
' Zeigt sehr viele Möglichkeiten, wie man mit VBS eine Datei-
' bzw. Verzeichnisauswahl realisieren kann.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox BrowseForFolder( "Verzeichnis auswählen:", 9+16384, 0 ), , WScript.ScriptName
WScript.Quit
'*** v9.4 *** www.dieseyer.de ******************************
Function BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'***********************************************************
' http://www.codecomments.com/message367170.html
' http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_frm/thread/f083a8d1806e9a68/d835b2a1ec45afec?lnk=st&q=BrowseForFolder+strPrompt+intBrowseInfo+vRootFolder&rnum=1&hl=de#d835b2a1ec45afec
'
'BrowseForFolder dialog. Follows MSDN example closely. Also handles selection of special
'folders (ex Desktop), which do not return a folder3 object as 'normal' folders do.
'Code below does not support all options, only folders.
'To use, copy and paste function into script,
'call as BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder) where root folder is either an
'integer (constants below) or a string with a folder path.
'To use the constants below, they must be in the script header.
'Flags specifying the options for the dialog box. This member can include zero or a combination of the following values.
Const BIF_BROWSEFORCOMPUTER = 4096 'Only return computers. If the user selects anything other than a computer, the OK button is grayed.
Const BIF_BROWSEFORPRINTER = 8192 'Only allow the selection of printers. If the user selects anything other than a printer, the OK button is grayed. In Microsoft Windows XP, the best practice is to use an XP-style dialog, setting the root of the dialog to the Printers and Faxes folder (CSIDL_PRINTERS).
Const BIF_BROWSEINCLUDEFILES = 16384 'Version 4.71. The browse dialog box will display files as well as folders.
'Const BIF_BROWSEINCLUDEURLS = 'Version 5.0. The browse dialog box can display URLs. The BIF_USENEWUI and BIF_BROWSEINCLUDEFILES flags must also be set. If these three flags are not set, the browser dialog box will reject URLs. Even when these flags are set, the browse dialog box will only display URLs if the folder that contains the selected item supports them. When the folder's IShellFolder::GetAttributesOf method is called to request the selected item's attributes, the folder must set the SFGAO_FOLDER attribute flag. Otherwise, the browse dialog box will not display the URL.
Const BIF_DONTGOBELOWDOMAIN = 2 'Do not include network folders below the domain level in the dialog box's tree view control.
Const BIF_EDITBOX = 16 'Version 4.71. Include an edit control in the browse dialog box that allows the user to type the name of an item.
'Const BIF_NEWDIALOGSTYLE = 'Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_NONEWFOLDERBUTTON = 512 'Version 6.0. Do not include the New Folder button in the browse dialog box.
'Const BIF_NOTRANSLATETARGETS = 'Version 6.0. When the selected item is a shortcut, return the PIDL of the shortcut itself rather than its target.
Const BIF_RETURNFSANCESTORS = 8 'Only return file system ancestors. An ancestor is a subfolder that is beneath the root folder in the namespace hierarchy. If the user selects an ancestor of the root folder that is not part of the file system, the OK button is grayed. Const BIF_RETURNONLYFSDIRS = 1 'Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
'Const BIF_SHAREABLE = 'Version 5.0. The browse dialog box can display shareable resources on remote systems. It is intended for applications that want to expose remote shares on a local system. The BIF_NEWDIALOGSTYLE flag must also be set.
Const BIF_STATUSTEXT = 4 'Include a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. This flag is not supported when BIF_NEWDIALOGSTYLE is specified.
'Const BIF_UAHINT = 'Version 6.0. When combined with BIF_NEWDIALOGSTYLE, adds a usage hint to the dialog box in place of the edit box. BIF_EDITBOX overrides this flag.
'Const BIF_USENEWUI = 'Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE. To use BIF_USENEWUI, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_VALIDATE = 32 'Version 4.71. If the user types an invalid name into the edit box, the browse dialog box will call the application's BrowseCallbackProc with the BFFM_VALIDATEFAILED message. This flag is ignored if BIF_EDITBOX is not specified.
Const ssfALTSTARTUP = 29 'File system directory that corresponds to the user's nonlocalized Startup program group. (value = 29)
Const ssfAPPDATA = 26 'Version 4.71. File system directory that serves as a common repository for application-specific data. A typical path is C:\Documents and Settings\username\Application Data. (value = 26)
Const ssfBITBUCKET = 10 'Virtual folder containing the objects in the user's Recycle Bin. (value = 15)
Const ssfCOMMONALTSTARTUP = 30 'File system directory that corresponds to the nonlocalized Startup program group for all users. Valid only for Microsoft Windows NT systems. (value = 30)
Const ssfCOMMONAPPDATA = 35 'Version 5.0. Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data. (value = 35)
Const ssfCOMMONDESKTOPDIR = 25 'File system directory that contains files and folders that appear on the desktop for all users. A typical path is C:\Documents and Settings\All Users\Desktop. Valid only for Windows NT systems. (value = 25)
Const ssfCOMMONFAVORITES = 31 'File system directory that serves as a common repository for all users' favorite items. Valid only for Windows NT systems. (value = 31)
Const ssfCOMMONPROGRAMS = 23 'File system directory that contains the directories for the common program groups that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs. Valid only for Windows NT systems. (value = 23)
Const ssfCOMMONSTARTMENU = 22 'File system directory that contains the programs and folders that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu. Valid only for Windows NT systems. (value = 22)
Const ssfCOMMONSTARTUP = 24 'File system directory that contains the programs that appear in the Startup folder for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs\Startup. Valid only for Windows NT systems. (value = 24)
Const ssfCONTROLS = 3 'Virtual folder containing icons for the Control Panel applications. (value = 3)
Const ssfCOOKIES = 33 'File system directory that serves as a common repository for Internet cookies. A typical path is C:\Documents and Settings\username\Cookies. (value = 33)
Const ssfDESKTOP = 0 'Microsoft Windows Desktop—virtual folder that is the root of the namespace. (value = 0)
Const ssfDESKTOPDIRECTORY = 16 'File system directory used to physically store the file objects that are displayed on the desktop. It is not to be confused with the desktop folder itself, which is a virtual folder. A typical path is C:\Documents and Settings\username\Desktop. (value = 16)
Const ssfDRIVES = 17 'My Computer—virtual folder containing everything on the local computer: storage devices, printers, and Control Panel. This folder may also contain mapped network drives. (value = 17)
Const ssfFAVORITES = 6 'File system directory that serves as a common repository for the user's favorite items. A typical path is C:\Documents and Settings\username\Favorites. (value = 6)
Const ssfFONTS = 20 'Virtual folder containing installed fonts. A typical path is C:\WINNT\Fonts. (value = 20)
Const ssfHISTORY = 34 'File system directory that serves as a common repository for Internet history items. (value = 34)
Const ssfINTERNETCACHE = 32 'File system directory that serves as a common repository for temporary Internet files. A typical path is C:\Documents and Settings\username\Temporary Internet Files. (value = 32)
Const ssfLOCALAPPDATA = 28 'Version 5.0. File system directory that serves as a data repository for local (non-roaming) applications. A typical path is C:\Documents and Settings\username\Local Settings\Application Data. (value = 28)
Const ssfMYPICTURES = 39 'My Pictures folder. A typical path is C:\Documents and Settings\username\My Documents\My Pictures. (value = 39)
Const ssfNETHOOD = 19 'A file system folder containing the link objects that may exist in the My Network Places virtual folder. It is not the same as ssfNETWORK, which represents the network namespace root. A typical path is C:\Documents and Settings\username\NetHood. (value = 19)
Const ssfNETWORK = 21 'Network Neighborhood—virtual folder representing the root of the network namespace hierarchy. (value = 18)
Const ssfPERSONAL = 5 'File system directory that serves as a common repository for a user's documents. A typical path is C:\Documents and Settings\username\My Documents. (value = 5)
Const ssfPRINTERS = 4 'Virtual folder containing installed printers. (value = 4)
Const ssfPRINTHOOD = 18 'File system directory that contains the link objects that may exist in the Printers virtual folder. A typical path is C:\Documents and Settings\username\PrintHood. (value = 27)
Const ssfPROFILE = 40 'Version 5.0. User's profile folder. (value = 40)
Const ssfPROGRAMFILES = 38 'Version 5.0. Program Files folder. A typical path is C:\Program Files. (value = 38)
Const ssfPROGRAMS = 2 'File system directory that contains the user's program groups (which are also file system directories). A typical path is C:\Documents and Settings\username\Start Menu\Programs. (value = 2)
Const ssfRECENT = 8 'File system directory that contains the user's most recently used documents. A typical path is C:\Documents and Settings\username\Recent. (value = 8)
Const ssfSENDTO = 9 'File system directory that contains Send To menu items. A typical path is C:\Documents and Settings\username\SendTo. (value = 9)
Const ssfSTARTMENU = 11 'File system directory containing Start menu items. A typical path is C:\Documents and Settings\username\Start Menu. (value = 11)
Const ssfSTARTUP = 7 'File system directory that corresponds to the user's Startup program group. The system starts these programs whenever any user logs onto Windows NT or starts Windows 95. A typical path is C:\Documents and Settings\username\Start Menu\Programs\Startup. (value = 7)
Const ssfSYSTEM = 37 'Version 5.0. System folder. A typical path is C:\WINNT\SYSTEM32. (value = 37)
Const ssfTEMPLATES = 21 'File system directory that serves as a common repository for document templates. (value = 21)
Const ssfWINDOWS = 36 'Version 5.0. Windows directory or SYSROOT. This corresponds to the %windir% or %SYSTEMROOT% environment variables. A typical path is C:\WINNT. (value = 36)
Dim oShell
Dim oFolder
Dim oFolderItem
Dim strPath
Dim oWSHShell
Dim oFSO
Dim bSuccess
Dim errTst
Set oShell = CreateObject("Shell.Application")
Set oWSHShell = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
'syntax: oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [,vRootFolder])
Set oFolder = oShell.BrowseForFolder(&H0, strPrompt, intBrowseInfo, vRootFolder)
On Error Resume Next
'This seems to get a 'normal' folder object from the folder3 object returned by BrowseForFolder
Set oFolderItem = oFolder.Items.Item
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
' MsgBox "Invalid selection; Please try again", , "110 :: " & WScript.ScriptName
Else
'If a special folder (ex. desktop) is selected, object is nothing.
If (oFolderItem Is Nothing) Then
'This is necessary - seems to convert invalid object reference to a string?
strPath = oFolder
Set oFolderItem = oFSO.GetFolder(oWSHShell.SpecialFolders(strPath))
End If
End If
On Error Resume Next
If Not oFSO.FolderExists(oFolderItem.Path) Then
On Error GoTo 0
MsgBox "Invalid selection; Please try again", , "125 :: " & WScript.ScriptName
Else
bSuccess = True
End If
Loop While Not bSuccess
BrowseForFolder = oFolderItem.Path
End Function ' BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
#########################################################################
>>> cd-lw-auf-zu.vbs <<<
Txt = "Jetzt gehts gleich auf . . . "
Set WSHShell = WScript.CreateObject("WScript.Shell")
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 64
set mp = WScript.CreateObject("WMPlayer.OCX")
mp.cdromcollection.item(0).eject
set mp = nothing
Txt = ". . . jetzt ist es auf, das CD-Laufwerk!"
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 16
' WScript.Sleep 10*1000
WScript.CreateObject("WScript.Shell").Popup "Jetzt gehts wieder zu . . . ", 10, WScript.ScriptName, 4096 + 48
WScript.CreateObject("WMPlayer.OCX").cdromcollection.item(0).eject
WScript.CreateObject("WScript.Shell").Popup "Jetzt ist das Laufwerk wieder zu . . . wenn es kein Notebook ist!", 10, WScript.ScriptName, 4096 + 32
#########################################################################
>>> cd-lw-ermitteln.vbs <<<
'*** v5.9 *** www.dieseyer.de *******************************
'
' Datei: cd-lw-ermitteln.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' ermittelt, ob eine best. CD eingelegt ist
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox CDLwTest("SU930"), , WScript.ScriptName
WScript.Quit
'*** v5.9 *** www.dieseyer.de *******************************
Function CDLwTest( Text )
'************************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim DriveList : Set DriveList = fso.Drives
Dim Lw
CDLwTest = "Falsche CD im Laufwerk."
For Each Lw in DriveList
if 4 = Lw.DriveType Then ' CD-Laufwerk
' if 4 = Lw.DriveType Then ' Wechseldatenträger
If Lw.IsReady Then
' If InStr( UCase( Lw.VolumeName ) , UCase( Text ) ) Then CDLwTest = Lw.VolumeName
If InStr( UCase( Lw.VolumeName ) , UCase( Text ) ) Then CDLwTest = Lw.DriveLetter & ":\"
End If
End If
Next
End Function ' Function CDLwTest( 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
#########################################################################
>>> cdrom-auf-zu.vbs <<<
Txt = "Jetzt gehts gleich auf . . . "
Set WSHShell = WScript.CreateObject("WScript.Shell")
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 64
set mp = WScript.CreateObject("WMPlayer.OCX")
mp.cdromcollection.item(0).eject
set mp = nothing
Txt = ". . . jetzt ist es auf, das CD-Laufwerk!"
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 16
' WScript.Sleep 10*1000
WScript.CreateObject("WScript.Shell").Popup "Jetzt gehts wieder zu . . . ", 10, WScript.ScriptName, 4096 + 48
WScript.CreateObject("WMPlayer.OCX").cdromcollection.item(0).eject
WScript.CreateObject("WScript.Shell").Popup "Jetzt ist das Laufwerk wieder zu . . . wenn es kein Notebook ist!", 10, WScript.ScriptName, 4096 + 32
#########################################################################
>>> changefilenames-imag0001.vbs <<<
'v5.6*************************************************************************************
' File: changefilenames-imag0001.vbs
' Autor: Peter Ladnar, erweitert von Michael Wende
'
' Beschreibung:
' Digitale Bilddateien einer Digicam eines bestimmten Verz. umbennen und neu durchnummerieren
'
' Meine Version geht davon aus, dass die Bilddateien im Digicam Ordner von verschiedenen
' Anlässen, wie Geburtstag, Gartenparty, Urlaub e.t.c. als z.B IMAG0001 bis IMAG0144 vorliegen,
' wobei z.B. IMAG0001 - IMAG0012 Bilddateien vom Geburtstag sind.
' IMAG0013 - IMAG0025 Bilddateien von einer Gartenparty u.s.w.
' Nun können diese Bilddateien eindeutig umbenannt werden. Das Skript ändert bei z.B. Eingabe
' von "0013 - 0025" und "Gartenparty Sommer" die Dateien IMAG0013 - IMAG0025 in
' "Gartenparty Sommer0001" - "Gartenparty Sommer0013" um.
'
'*****************************************************************************************
' Zum Debuggen: script //d name.vbs stop
' Start des Hauptprogrammes **************************************************************
Dim strNewName, objPath, intValue,start,ende,z
Dim songtab(),startzahl,endzahl,h,VonBis,i
Dim ausgabetab(),leni,lenh1,isda
strNewName = Empty
FolderAuswahl
VonBis = InputBox ("Von welcher Datei bis zu welcher Datei umbenennen?","Bitte Ziffern innerhalb der eckigen Klammern max 4stellig eintragen","[0001] - [0012]")
If VonBis = "" Then WScript.Quit
' Hole Start und Endwert als Cstr
start = Mid(VonBis,2,4)
ende = Mid(VonBis,11,4)
' Führende "0" en werden ausgefiltert
startzahl= TrimleadingZeroes(start)
endzahl = TrimleadingZeroes(ende)
' Tabellen mit Werten füllen.
' Die songtab() Tabelle nimmt die Vergleichswerte auf, während die ausgabetab() Tabelle die
' Änderungswerte aufnimmt.
' Beispiel: Geändert werden sollen die Fotodateien Imag0007 - Imag0010
' in BildervonLisa.
' Das Programm erstellt dann BildervonLisa0001 - BilderVonLisa0004
' Gesucht werden Dateiendungen 0007 - 0010 = songtab() Werte
' Geändert werden die Dateien in 0001 - 0004 = ausgabetab() Werte.
For i = Cint(startzahl) To Cint(endzahl)
h = CInt(i) - CInt(startzahl)
leni = Len(i)
lenh1 = Len(h+1)
ReDim Preserve songtab(h+1)
ReDim Preserve ausgabetab(h+1)
Select Case leni
Case 1 songtab(h) = "000" & CStr(i)
Case 2 songtab(h) = "00" & CStr(i)
Case 3 songtab(h) = "0" & CStr(i)
Case Else songtab(h) = CStr(i)
End Select
Select Case lenh1
Case 1 ausgabetab(h) = "000" & CStr(h+1)
Case 2 ausgabetab(h) = "00" & CStr(h+1)
Case 3 ausgabetab(h) = "0" & CStr(h+1)
Case Else ausgabetab(h) = CStr(h+1)
End Select
Next
ShowFolderList objPath ' Hier wird der neue Name eingegeben
For z = Lbound(songtab) to Ubound(songtab)-1 ' Dateien suchen und ändern
ShowFileList objPath,songtab(z),ausgabetab(z)
Next
MsgBox "Alle Dateien umbenannt, fertig ",0,"Digi-Photo Tool, Ende"
' Ende des Hauptprogrammes *****************************************************************
' Start Sub Routinen und Funktionsbeschreibungen *******************************************
Sub FolderAuswahl
isda = EintraginsKontextmenue()
If isda = True then
objPath = CurrentDir ' Für die Einbindung ins Kontextmenü des Windows Explorers.
else
objPath = BrowseForFolder("Ordner mit Bildern auswählen:",&h1, "C:\Eigene Dateien")
End If
End Sub
Sub ShowFolderList(folderspec)
Dim s, x,k
x = 0
s = objPath & ":" & vbCrLf & vbCrLf
For k = Lbound(songtab) to Ubound(songtab)-1
If (x < 10) Then
s = s & songtab(k)
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 & "Dateien mit diesem Mustertyp und alle anderen Dateien umbenennen in:"
strNewName = InputBox (s,WScript.Scriptname & " - Neuer Dateiname","Neuen Namen eingeben")
If (IsEmpty(strNewName) = True) Then
WScript.Quit
End If
End Sub
Sub ShowFileList(folderspec,suchmuster,renmuster)
Dim fs, f, f1, fc, zahl
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
If IsinStr(suchmuster, f1) = True Then
RenameFile f1, renmuster
Exit For
End If
Next
End Sub
Function IsinStr(muster, zkette)
Dim regEx, retVal ' Variablen,die ich brauche.
Set regEx = New RegExp ' Regulären Ausdruck erstellen.
regEx.Pattern = muster ' Setze Muster.
regEx.IgnoreCase = True ' Groß-Kleinschreibung ausschalten.
retVal = regEx.Test(zkette) ' Führe Durchsuchung aus.
if retVal Then IsinStr = True Else IsinStr = False
End Function
Function RenameFile(fileName, x)
Dim objFSO, strDest, strName, strExt, strMessage,intValue
strName = "\" & strNewName & x
strExt = Lcase(right(fileName,4))
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
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDest = objPath & strName & strExt
' If ExistFile(strDest) = False then
objFSO.CopyFile fileName , strDest , OverWriteFiles
objFSO.DeleteFile fileName
' End If
End Function
Function BrowseForFolder(strPrompt, BrowseInfo, root)
On Error Resume Next
Dim objShell, objFolder, intColonPos, objWshShell, returnerror
Set objShell = WScript.CreateObject("Shell.Application")
Set objWshShell = CreateObject("WScript.Shell")
Set objFolder = objShell.BrowseForFolder(&H0, strPrompt, BrowseInfo, root)
BrowseForFolder = objFolder.ParentFolder.ParseName(objFolder.Title).Path
returnerror = err.number
If returnerror <> 0 Then
If returnerror = 424 then
BrowseForFolder = Null
else
intColonPos = InStr(objFolder.Title, ":")
If intColonPos > 0 Then
BrowseForFolder = Mid(objFolder.Title, intColonPos - 1, 2) & "\"
End If
End If
End If
End Function
Function ExistFile(files)
Dim fio, msg
Set fio = CreateObject("Scripting.FileSystemObject")
If (fio.FileExists(files)) Then
ExistFile = True
Else
ExistFile = False
End If
End Function
Function CurrentDir
Dim newfso
Set newfso = WScript.CreateObject("Scripting.FileSystemObject")
CurrentDir = newfso.GetAbsolutePathName(".")
End Function
Function TrimleadingZeroes(mystring)
Dim ind,helpme,erg
erg=""
helpme=""
For ind = 1 To Len(mystring)
helpme = Mid(mystring,ind,1)
If helpme <> "0" Then erg = erg + helpme
If Len(erg) >= 1 And helpme = "0" Then erg = erg + "0"
Next
TrimleadingZeroes = erg
End Function
Function EintraginsKontextmenue()
dim WSHShell, KeyNew, path, kontext,m,asatz
dim KeyToo,Eintrag
Set WSHShell =WScript.CreateObject ("WScript.Shell")
path = WScript.ScriptFullName
kontext = "Bilder umbenennen"
EintraginsKontextmenue = False
KeyNew="HKCR\AllFilesystemObjects\shell\" & kontext & "\command\"
If WSHShell.RegRead(KeyNew) = "" then
Eintrag = InputBox ("Möchten Sie dieses Skript ins Kontextmenü des Explorers einbinden?",vbYesNo)
If Eintrag = vbYes then
WSHShell.RegWrite KeyNew,"wscript " & path
EintraginsKontextmenue = True
MsgBox("Eintrag als *" & kontext & "* wurde neu angelegt.")
End If
Else
EintraginsKontextmenue = True
end if
End Function
' Ende Sub Routinen und Funktionsbeschreibungen *******************************************
#########################################################################
>>> 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
#########################################################################
>>> chkdsk-defrag.vbs <<<
@echo off
echo j| chkdsk c: /F/R
echo nj| chkdsk d: /F/R
start /w DEFRAG.EXE C: -f
start /w DEFRAG.EXE D: -f
shutdown -r -t 30
#########################################################################
>>> computer-function.vbs <<<
'*** v8.1 *** www.dieseyer.de *******************************
'
' Datei: computer-function.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "Verify Computer Role"
'
'************************************************************
Option Explicit
Dim strComputer
strComputer = WScript.CreateObject("WScript.Network").ComputerName
MsgBox " """ & strComputer & """ ist" & vbCRLF & vbCRLF & ComputerFu( strComputer ), , WScript.ScriptName
WScript.Quit
'*** v8.1 *** www.dieseyer.de ****************************
Function ComputerFu( PCname )
'*********************************************************
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCname & "\root\cimv2")
Dim colComputers : Set colComputers = objWMIService.ExecQuery("Select DomainRole from Win32_ComputerSystem")
Dim objComputer
Dim strComputerRoleTxt
For Each objComputer in colComputers
Select Case objComputer.DomainRole
Case 0
strComputerRoleTxt = "Standalone Workstation"
Case 1
strComputerRoleTxt = "Member Workstation"
Case 2
strComputerRoleTxt = "Standalone Server"
Case 3
strComputerRoleTxt = "Member Server"
Case 4
strComputerRoleTxt = "Backup Domain Controller"
Case 5
strComputerRoleTxt = "Primary Domain Controller"
End Select
ComputerFu = objComputer.DomainRole
Next
ComputerFu = ComputerFu & ": " & strComputerRoleTxt
End Function ' ComputerFu( PCname )
#########################################################################
>>> convert-b4s-to-m3u.vbs <<<
'v5.C===========================================================================================
'
' NAME: convert-b4s-to-m3u.vbs
'
' AUTOR: Michael Wende - wende@helimail.de
' dieseyer.de
' DATUM: 28.12.05
'
' KOMMENTAR: Wandelt in einem angegebenen Ordner alle .4bs Winampplaylistdatei(en)
' in m3u Playlist(en). Die Idee kam mir, als ich einige Winamp Playlisten
' für die Sylvesterparty auf CD brennen wollte. Mir fiel auf, dass ich
' noch einige .b4s Winamp3 Playlisten auf meinem Rechner habe. Mittlerweile
' habe ich Winamp 5 im Einsatz. Zu meinem Entsetzen kann Winamp 5 diese nicht
' abspielen oder konvertieren. Auch mein Brennprogramm Nero kann mit .b4s
' Dateien nichts anfangen. Bei meiner Suche im Internet kam ich auf ein
' Freewaretool "veeXChange" von www.krank.hu. Mein Virenscanner meinte aber,
' dass diese .zip Datei verseucht sei und löschte sie wieder.
' So kam ich auf die Idee, mir ein geeignetes Skript selbst zu schreiben...
'==================================================================================================
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim myxmlstr,myxmlstr2,myxmlstr3
Dim myfsObject,dateiname,m3uFile,textziel
Dim Ordner,Song,Laenge,arg,antwort
Dim strfiles(),vonAnfang,bisEnde,i,anzfiles
Set myfsObject=CreateObject("Scripting.FileSystemObject")
Set oFs=CreateObject("Scripting.FileSystemObject")
arg = BrowseForFile("Bitte Ordner mit .b4s Playlisten auswählen!","Ordnerwahl")
If arg = "" Then
WScript.Quit
End If
If Mid(arg,Len(arg),Len(arg))= "\" then ' Ist Backslash am Ende,dann OK
textziel = arg
Else
textziel = arg & "\" ' sonst Backslash anhängen
End If
Redim strfiles(0)
strfiles(0)=""
anzfiles=0
walkdirs(textziel)
If anzfiles > 0 Then
antwort= MsgBox("Fertig! m3u Playliste(n) wurden erstellt. Möchten Sie jetzt die .b4s Playlisten löschen?",VbYesNo,"Achtung!")
If antwort = VbYes Then
vonAnfang =LBound(strfiles) : bisEnde = UBound(strfiles)
For i=vonAnfang To bisEnde
' MsgBox strfiles(i) & " wird gelöscht!"
oFs.DeleteFile(strfiles(i))
Next
MsgBox "Alle .b4s Winamp3 Playlisten wurden gelöscht!"
End If
Else
MsgBox "Sorry, ich konnte leider keine .b4s Winamp3 Playlisten finden!"
End If
' Ende des Programmes
' ********* Funktionen und Unterprogramme (Subs) **********************************************************
'*********************************************************
Sub walkdirs(arg)
'*********************************************************
If oFs.FolderExists(arg) Then
Set thisDir = oFs.GetFolder(arg)
Set subDirs = thisDir.SubFolders
Set theseFiles = thisDir.Files
If subDirs.Count > 0 Then
For Each dirName in subDirs
walkdirs(dirName)
Next
End If
For Each fileName in theseFiles
If oFs.GetExtensionName(fileName) = "b4s" Then
If strfiles(0) = "" Then
strfiles(0) = fileName
Else
Redim Preserve strfiles(Ubound(strfiles,1) + 1)
strfiles(Ubound(strfiles,1)) = fileName
End If
End If
walkdirs(fileName)
Next
ElseIf oFs.FileExists(arg) Then
If oFs.GetExtensionName(arg) = "b4s" Then
convertFile(arg)
End If
End If
End Sub ' walkdirs(arg)
'*********************************************************
Sub convertFile(fname)
'*********************************************************
'Zur Veranschaulichung konvertiert wird von Beispiel1 nach Beispiel2
'Beispiel1 .b4s Winampplaylist
'<?xml version="1.0" encoding="us-ascii" standalone="yes"?>
'<WinampXML>
' <playlist num_entries="0" label="">
' <entry Playstring="H:\CREAM - Cream Live\01 - CREAM - N.S.U..mp3">
' <Name>CREAM - N.S.U.</Name>
' <Length>615000</Length></entry>
' <entry Playstring="H:\CREAM - Cream Live\02 - CREAM - Sleepy Time Time.mp3">
' <Name>CREAM - Sleepy Time Time</Name>
' <Length>412000</Length></entry>
'
'Beispiel2 .m3u Winampplaylist
'#EXTM3U
'#EXTINF:615,CREAM - N.S.U.
'01 - CREAM - N.S.U..mp3
'#EXTINF:412,CREAM - Sleepy Time Time
'02 - CREAM - Sleepy Time Time.mp3
Dim m3ufile,sMP3,oFS,oFile,oM3U
m3ufile = Left(fname, Len(fname) - 4) & ".m3u" ' = Ausgabedatei
Set oFS = CreateObject("Scripting.FileSystemObject")
Set m3uFile=oFS.CreateTextFile(m3ufile, 1) ' Ausgabedatei öffnen
Set oFile = oFS.GetFile(fname)
Set oM3U = oFile.OpenAsTextStream
m3uFile.WriteLine("#EXTM3U") ' Den Anfang einer .m3u Datei schreiben
anzfiles=anzfiles + 1 ' zähle die Anzahl der .b4s Dateien
Ordner="":Song="":Laenge="" ' Was ich jetzt öfter belege, initialisieren
do while not oM3U.AtEndOfStream ' .b4s Datei lesen und .m3u Datei erstellen
sMP3 = oM3U.ReadLine
If IsinStr("<entry Playstring=", sMP3)= True Then Ordner = stripfromxml(sMP3,"<entry Playstring=",">")
if IsinStr("<Name>", sMP3)= True Then Song = stripfromxml( sMP3,"<Name>","</Name>")
if IsinStr("<Length>", sMP3)= True Then Laenge = stripfromxml( sMP3,"<Length>","</Length>")
' Die 3 relevanten Daten werden aus der .b4s (XML)Datei extrahiert
' und den Variablen Song,Ordner,Laenge übergeben
If Song <> "" And Laenge <> "" Then
Song = HtmlDecode(Song) ' Sonderzeichen der XML .b4s Datei dekodieren
m3uFile.WriteLine "#EXTINF:" & Laenge & ","& Song
Song="" : Laenge = ""
If Ordner <> "" Then
Ordner = Mid(Ordner,2,Len(Ordner)-2)
Ordner = HtmlDecode(Ordner) ' Sonderzeichen der XML .b4s Datei dekodieren
m3uFile.WriteLine Ordner
Ordner=""
End If
End If
Loop
m3uFile.Close
End Sub ' convertFile(fname)
'*********************************************************
Function stripfromxml (xmlstring,xmlpart1,xmlpart2)
'*********************************************************
Dim pos1,pos2,thename
thename=""
pos1 = instr(xmlstring,xmlpart1)
If pos1 Then
thename = mid(xmlstring,pos1+len(xmlpart1),Len(xmlstring))
End If
pos2 = instr(thename,xmlpart2)
If pos2 then thename = mid(thename,1,(pos2)-1)
If xmlpart1="<Length>" then thename = striplastzeroes(thename) ' Länge wird mit 6 Ziffern angegeben, deshalb letzte Nullen löschen
stripfromxml = thename ' das kann zu falschen Songlängen führen. siehe unten.
End Function ' stripfromxml (xmlstring,xmlpart1,xmlpart2)
'*********************************************************
Function BrowseForFile(strPrompt,strtitle)
'*********************************************************
'Benutzt die "Shell.Application" (nur anzutreffen in Win98 and neuer)
'um das Datei/Ordner Fenster aufzurufen. Nicht unter Win95.
'Shell32.ShellSpecialFolderKonstanten
Const ssfPERSONAL = 5 'Meine Dokumente
Const ssfDRIVES = 17 'Mein Computer
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2
Const SFVVO_SHOWFILES = 16384
Dim sh, fol, fs, lngView, strPath,i
Set sh = CreateObject("Shell.Application")
If Instr(TypeName(sh), "Shell") = 0 Then
BrowseForFile = InputBox(strPrompt, strtitle, CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "Pfad\Dateiname")
Exit Function
End If
Set fs = CreateObject("Scripting.FileSystemObject")
lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS Or SFVVO_SHOWFILES
strPath = ""
Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
On Error Resume Next
strPath = fol.ParentFolder.ParseName(fol.Title).Path
If strPath = "" Then
strPath = fol.Title
Set fol = fol.ParentFolder
strPath = fs.BuildPath(fol.ParentFolder.ParseName(fol.Title).Path, strPath)
i = InStr(strPath, ":")
strPath = Mid(strPath, i - 1, 1) & ":\" ' Nur Laufwerk:\ zurückgeben
End If
BrowseForFile = strPath
End Function ' BrowseForFile(strPrompt,strtitle)
'*********************************************************
Function IsinStr(muster, zkette)
'*********************************************************
Dim regEx, retVal ' Variablen,die ich brauche.
Set regEx = New RegExp ' Regulären Ausdruck erstellen.
regEx.Pattern = muster ' Setze Muster.
regEx.IgnoreCase = True ' Groß-Kleinschreibung ausschalten.
retVal = regEx.Test(zkette) ' Führe Durchsuchung aus.
if retVal Then IsinStr = True Else IsinStr = False
End Function ' IsinStr(muster, zkette)
'*********************************************************
public Function HtmlDecode( sText)
'*********************************************************
'Wie in HTML müssen auch in XML Sonderzeichen speziell formatiert werden. Die fünf Zeichen &, ', <, > und "
'werden wie in HTML angegeben:
' ' hex ´ oder '
' & &
' < <
' > >
' " "
'Umlaute und das ß müssen aber so definiert werden:
' Ä Ä hex c4
' Ö Ö hex d6
' Ü Ü hex dc
' ä ä hex e4
' ö ö hex f6
' ü ü hex fc
' ß ß hex df
' € € hex 20ac
' Alles dies erledigt die Function HtmlDecode
sText = Replace(sText, "Ä", "Ä")
sText = Replace(sText, "Ö", "Ö")
sText = Replace(sText, "Ü", "Ü")
sText = Replace(sText, "ä", "ä")
sText = Replace(sText, "ö", "ö")
sText = Replace(sText, "ü", "ü")
sText = Replace(sText, "ß", "ß")
sText = Replace(sText, "€", "€")
sText = Replace(sText, "?", "'")
sText = Replace(sText, "<", "<")
sText = Replace(sText, ">", ">")
'sText = Replace(sText, """, """")
sText = Replace(sText, "$", "$")
sText = Replace(sText, "&", "&")
sText = Replace(sText, "´", "'")
sText = Replace(sText, """, """")
sText = Replace(sText, " ", " ")
sText = Replace(sText, "&bsp;", " ")
HtmlDecode = sText
End Function ' HtmlDecode( sText)
'*********************************************************
Function striplastzeroes(strNumber)
'*********************************************************
' Es kann sein, dass die Songlänge nicht richtig angegeben wird; denn
' in .b4s Playlisten werden 6 Ziffern für die Dateilänge verwendet.
' Ist ein Song 1000 Sekunden lang wird er nach der striplastzeroes Funktion
' auf 100 Sekunden gekürzt. Das ist jedoch nicht so schlimm, wie es scheint,
' da Winamp die falsche Songdauer automatisch korrigert.
Dim MyLong1
MyLong1 = CLng(strNumber)
If (MyLong1 mod 1000) <> 0 Then
striplastzeroes = CStr(Mylong1/100)
Else
striplastzeroes = CStr(Mylong1/1000)
End If
End Function ' striplastzeroes(strNumber)
#########################################################################
>>> copy_mp3_aus_m3u.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: copy_mp3_aus_m3u.vbs
' Autor: Wolfgang Binder
' FamilieBinder@web.de
' Auf: www.dieseyer.de
'
'***********************************************************
'********************************************************************************************
'
'geschrieben für Windows-Script Version 5.6
'
'Dieses Windows-Scrip kopiert MP3-Dateien aus einer M3U-Liste in ein Ziel-Verzeichnis
'dabei kann man per Parameter auswählen ob man die MP3-Dateien
' 1.) Flach alle in das gleiche Verzeichnis
' 2.) Mit Verzeichnis / Unterverzeichnis
' 3.) In ein Register A,B,C,D,...Z, nach dem Dateinamen geordnet
'kopiert. Beim Kopieren werden um Zeit zu sparen nur die noch fehlenden Dateien eingefügt.
'
' Hintergrund war daß ich meine MP3-Dateien zufällig auf meinen Stick kopieren wollte. Zum Erstellen
' der M3U Liste (Zufall) habe ich Winamp verwendet. Danach habe ich mir eine Mulimedia-Festplatte
' gekauft die leider keine M3U Listen verwendet aber viel Platz hat, also habe ich ein Grundverzeichnis
' für meine Musik und kopiere über dieses Script in ein Verzeichnis alle Dateien Flach
'(für Zufallsauswahl der Multimedia-Festplatte) und in ein anderes Verzeichnis alle Musik in ein Register.
'
'Das Script kann etweder über Eingabeparameter oder über die Konstanten gesteuert werden.
'Die einzelnen Konstanten zum Steuern des Scripts sind nachfolgend erklärt, die Eingabeparameter
'für das Script sind bei den Konstanteneinstellungen beschrieben bei Boolschen Variablen werden bei den
'Eingabeparametern anstatt True und False wird 0 und 1 angegeben 0 ==> False, 1 ==> True
'
'Beispiel für Start mit Argumenten
'"Copy_Mp3_aus_M3U.vbs" "/m3u:D:\Install\Musik\Best Of\Pop\Test.m3u" "/Ziel:D:\Temp\3" /Flach:1 /Register:1 /MaxAnzahl:19 /Protokoll:1 /MaxFehler:10 /ProtFile:1
'
'********************************************************************************************
'--------- Konstanteneinstellungen zum Steuern des Scriptes ---------------------------------
'M3U-Datei aus der kopiert werden soll z.B. D:\Install\Musik\Best Of\Pop\aa_Best of Pop_gemischt.m3u
'Eingabeparameter ist: /m3u: Default = ""
Const DATEI_M3U_LIST = "D:\Install\Musik\Best Of\Pop\Test.m3u"
'Lw-Pfad wohin die Mp3-Dateien hin kopiert werden sollen
'Eingabeparameter ist: /Ziel: Default = ""
Const ZIEL_PFAD = "D:\Temp\3"
'True ==> alle MP3-Files werden in das gleiche Ziel-Verzeichnis Kopiert (Ohne Unter-Verzeichnisse)
'False ==> die MP3-Files werden im Zielverzeichnis mit ihren Unter-Verzeichnisse kopiert
'Eingabeparameter ist: /Flach: Default = 0 Bedeutung: 0 = False 1=True
Const FLACH = False
'True ==> alle MP3-Files werden anhand des Dateinamens in ein Register Kopiert (_, A, B, C, D, ...)
'False ==> kein Register
'Eingabeparameter ist: /Flach: Default = 0 Bedeutung: 0 = False 1=True
Const REGISTER = False
'Anzahl der Maximal zu kopierenden Files, bei Angabe von 0 gibt es keine Grenze
'Eingabeparameter ist: /MaxAnzahl: Default = 0
Const MAX_ANZAHL = 0
'nach MAX_ANZAHL_FEHLER_COPY hintereinander fehlerhaften Kopiervorgängen wird abgebrochen.
'Eingabeparameter ist: /MaxFehler: Default = 30
Const MAX_ANZAHL_FEHLER_COPY = 30
'Nicht nur die Fehler sondern auch das kopieren der MP3-Files wird mitprotokolliert
'True ==> es wird protokolliert welche Mp3-Dateien kopiert wurden und welche nicht
'False ==> Mp3-Dateien kopieren wird nicht protokolliert.
'Eingabeparameter ist: /Protokoll: Default = 0 Bedeutung: 0 = False 1=True
Const MP3_PROTOKOLLIEREN = False
'True ==> es wird nicht nur das Protkoll auf dem Bildschirm ausgegeben,
' sondern auch in ein File Protokolliert.Der Name der Log-Datei seht in der
' Konstanten PROTOKOLL_DATEI und wird in das Verzeichnis geschrieben in dem die
' m3u-Datei geöffnet wurde. Im Gesamt Fehlerfall wird das Protoll nicht erzeugt.
'False ==> Protokoll wird nur auf dem Bildschirm ausgegeben.
'Eingabeparameter ist: /ProtFile: Default = 0 Bedeutung: 0 = False 1=True
Const MP3_PROTOKOLL_FILE = False
'Ist WARTEN > 0 wird der Task beim kopieren der MP3-Files für diese Zeiteinheit in Milli Sekunden
'abgegeben. Z.B. WARTEN = 100 dann bedeutet es das der Task für 100 Milli Sekunden abgegeben wird,
'bevor die nächste MP3-Datei kopiert wird.
'Je größer die Zahl desto länger dauert das kopieren der MP3-Files aber,
'man hat keine Schwierigkeiten andere Programme des PC's in dieser Zeit zu verwenden.
'Das kopieren wird ohne Schwierigkeiten für andere Programme im Hintergrund erledigt.
'
'Bei WARTEN = 0 wird der Task nicht abgegeben das kopieren der Files geht am schnellsten.
'Eingabeparameter ist: /Warten: Default = 0
Const WARTEN = 0
'True ==> Das Script kann von einem anderen Programm aufgerufen werden, darum sind die Bildschirmmeldungen
' unterdrückt und der Kopiervorgang wird in der Regestry eingetragen um die Möglichkeit
' zu geben mit einem anderen Programm für dessen Meldungen darauf zuzugreifen.
' Der Regestry-Pfad steht in REG_HAUPTSCHLUESSEL = HKCU\Software\VBScript\CopyMP3ausM3U\ in Run, Ok, Protokoll
'False ==> Kein Regestry-Eintrag und die Bildschirmmeldungen werden ausgegeben.
'Eingabeparameter ist: /Fremd: Default = 0 Bedeutung: 0 = False 1=True
Const FREMD = False
'--------------------------------------------------------------------------------------------
'----------------------Ende Konstanteneinstellungen zum Steuern des Scriptes ----------------
'--- Übergabe -Argumente an das Script (Die Variablennamen zur Übergabe)
Const ARG_DATEI_M3U_LIST = "m3u"
Const ARG_ZIEL_PFAD = "Ziel"
Const ARG_FLACH = "Flach"
Const ARG_REGISTER = "Register"
Const ARG_MAX_ANZAHL = "MaxAnzahl"
Const ARG_MAX_ANZAHL_FEHLER_COPY = "MaxFehler"
Const ARG_MP3_PROTOKOLLIEREN = "Protokoll"
Const ARG_MP3_PROTOKOLL_FILE = "ProtFile"
Const ARG_WARTEN = "Warten"
Const ARG_FREMD = "Fremd"
'-------------------- !!!!!!!!!! A C H T U N G !!! ----------------------------------------
'- -
'- Die weiteren Konstanten stehen nocheinmal in der Hauptfunktion Copy_MP3_Aus_M3U_List -
'- -
'---------------------------------------------------------------------------------------------
'---- für Registrierungsdatenbank ------------------------------------------------------------
Const REG_HKLM = "HKLM" 'HKEY_LOCAL_MACHINE
Const REG_HKCU = "HKCU" 'HKEY_CURRENT_USER
Const REG_HKCR = "HKCR" 'HKEY_CLASSES_ROOT
Const REG_HAUPTSCHLUESSEL = "HKCU\Software\VBScript\CopyMP3ausM3U\"
Const REG_OK = "Ok"
Const REG_RUN = "Run"
Const REG_PROTOKOLL = "Protokoll"
Const REG_FEHLER = "Fehler"
'---- Weitere Konstanten ---------------------------------------------------------------------
Const PROTOKOLL_DATEI = "CopyMp3.log"
'----- Steuervariablen für die an das Script übergebenen Parameter
Dim sArg_m3u
Dim sArg_Ziel
Dim sArg_Flach
Dim sArg_Register
Dim sArg_MaxAnzahl
Dim sArg_Protokoll
Dim sArg_MaxFehler
Dim sArg_ProtFile
Dim sArg_Warten
Dim sArg_Fremd
'weitere Variablen
Dim nAnzahlArgumente
Dim arrArgumente
Dim objArgs
Dim strElement
Dim objFs
Dim sM3U_Lw
Dim sM3U_Lw_Pfad
Dim sDatei_M3U_List
Dim sZielPfad
Dim bFlach
Dim bRegister
Dim nMaxAnzahl
Dim bMP3_Protolollieren
Dim nMaxAnzahlFehlerCopy
Dim bProtokollFile
Dim nWarten
Dim bFremd
Dim sProtokoll
Dim bOk
'****** Dem Programm die angegenenen Argumente übergeben ************************************************
Set objArgs = WScript.Arguments
nAnzahlArgumente = objArgs.Count
If nAnzahlArgumente = 0 Then
'--- dem Script wurden keine Argumente übergeben darum werden die Konstanteneinstellungen übernommen
sDatei_M3U_List = DATEI_M3U_LIST
sZielPfad = ZIEL_PFAD
bFlach = FLACH
bRegister = False
nMaxAnzahl = MAX_ANZAHL
bMP3_Protolollieren = MP3_PROTOKOLLIEREN
nMaxAnzahlFehlerCopy = MAX_ANZAHL_FEHLER_COPY
bProtokollFile = MP3_PROTOKOLL_FILE
nWarten = WARTEN
bFremd = FREMD
Else
'--- dem Script wurden Argumente übergeben die Konstanteneinstellungen werden ignoriert.
'--- Zunächst die Default-Einstellungen
sDatei_M3U_List = ""
sZielPfad = ""
bFlach = False
bRegister = False
nMaxAnzahl = 0
bMP3_Protolollieren = False
nMaxAnzahlFehlerCopy = 30
bProtokollFile = False
nWarten = 0
bFremd=False
'--- Jetzt die Argumente übergeben
arrArgumente = Array(ARG_DATEI_M3U_LIST, ARG_ZIEL_PFAD, ARG_FLACH, ARG_REGISTER, ARG_MAX_ANZAHL, ARG_MAX_ANZAHL_FEHLER_COPY, ARG_MP3_PROTOKOLLIEREN, ARG_MP3_PROTOKOLL_FILE, ARG_WARTEN, ARG_FREMD)
For Each strElement In arrArgumente
If objArgs.Named.Exists(strElement) Then
Execute "sArg_" & strElement & "= objArgs.named(strElement)"
End If
Next
If Len(sArg_m3u) > 0 Then
sDatei_M3U_List = sArg_m3u
end if
If Len(sArg_Ziel) > 0 Then
sZielPfad = sArg_Ziel
end if
If Len(sArg_Flach) > 0 Then
if sArg_Flach = "1" then
bFlach = True
else
bFlach = False
end if
End If
If Len(sArg_Register) > 0 Then
if sArg_Register = "1" then
bRegister = True
else
bRegister = False
end if
End If
If Len(sArg_MaxAnzahl) > 0 Then
nMaxAnzahl = CLng(sArg_MaxAnzahl)
End If
If Len(sArg_Protokoll) > 0 Then
if sArg_Protokoll = "1" then
bMP3_Protolollieren = True
else
bMP3_Protolollieren = False
end if
End If
If Len(sArg_MaxFehler) > 0 Then
nMaxAnzahlFehlerCopy = CLng(sArg_MaxFehler)
End If
If Len(sArg_ProtFile) > 0 Then
if sArg_ProtFile = "1" then
bProtokollFile = True
else
bProtokollFile = False
end if
End If
If Len(sArg_Warten) > 0 Then
nWarten = CLng(sArg_Warten)
End If
If Len(sArg_Fremd) > 0 Then
if sArg_Fremd = "1" then
bFremd = True
else
bFremd = False
end if
End If
End If
' -------------------------- Aufruf des Hauptprogrammes ----------------------------------------------------
bOk=Copy_MP3_Aus_M3U_List(sDatei_M3U_List, sZielPfad, bFlach, bRegister, nMaxAnzahl, bMP3_Protolollieren, sProtokoll, nMaxAnzahlFehlerCopy, nWarten, bFremd)
if bOk then
if bProtokollFile Then
Set objFs = CreateObject("Scripting.FileSystemObject")
sM3U_Lw = objFS.GetDriveName(sDatei_M3U_List)
sM3U_Lw_Pfad = objFS.GetParentFolderName(sDatei_M3U_List)
bOk =TextdateiSchreiben( sM3U_Lw_Pfad & "\" & PROTOKOLL_DATEI , sProtokoll, True)
end if
if bFremd then
else
WScript.Echo "MP3 Dateien kopiert" & vbNewLine & vbNewLine & sProtokoll
end if
else
if bFremd then
else
WScript.Echo "---- Fehler beim kopieren der M3U-Liste ------" & vbNewLine & vbNewLine & sProtokoll
end if
end if
'-------------------------------------------------------------------------
'Funktionsname: Copy_MP3_Aus_M3U_List
'Beschreibung: Kopiert Dateien von Quelle nach Ziel ohne direktem Feedback über den
' Kopiervorgang beim Anwender
'
' Die erforderlichen Pfade werden automatisch erzeugt
'
'ÜbergabeVariablen: sDatei_M3U_List: M3U-L-Datei aus der kopiert werden soll
' z.B. D:\Install\Musik\Best Of\Pop\aa_Best of Pop_gemischt.m3u
' sZielPfad: Lw-Pfad wohin die Mp3-dateien hin kopiert werden sollen
' bFlach: True ==> alle MP3-Files erden in das gleiche Verzeichnis Kopiert
' False ==> die MP3-Files werden in Ihre Ursprungs-Verzeichnisse kopiert
' bRegister True ==> alle MP3-Files werden anhand des Dateinamens
' in ein Register Kopiert (A, B, C, D, ...)
' False ==> kein Register
' nMaxAnzahl: Anzahl der Maximal zu kopierenden Files, bei Angabe von 0 gibt es keine Grenze
' bMP3_Protolollieren: Nicht nur die Fehler sondern auch das kopieren der MP3-Files wird mitprotokolliert
' True ==> es wird protokolliert welche Mp3-Dateien kopiert wurden und welche nicht
' False ==> Mp3-Dateien kopieren wird nicht protokolliert.
' sProtokoll: Protokoll-String
' nMaxAnzahlFehlerCopy: nach nMaxAnzahlFehlerCopy hintereinander fehlerhaften Kopiervorgängen wird abgebrochen
' nWarten: Ist WARTEN > 0 wird der Task beim kopieren der MP3-Files für diese Zeiteinheit
' in Milli Sekunden abgegeben. Z.B. WARTEN = 100 dann bedeutet es das der Task
' für 100 Milli Sekunden abgegeben wird, bevor die nächste MP3-Datei kopiert wird.
' bFremd: True ==> Das Script kann von einem anderen Programm aufgerufen werden, darum sind die
' Bildschirmmeldungen unterdrückt und der Kopiervorgang wird in der Regestry eingetragen
' um die Möglichkeit zu geben mit einem anderen Programm für dessen Meldungen auf die Registry zuzugreifen.
' False ==> Kein Regestry-Eintrag und die Bildschirmmeldungen werden ausgegeben.
'
'Rückgabewert: TRUE ==> Kopiervorgang der MP3-Dateien in der Regel OK (auch wenn einzelne Dateien nicht kopiert werden konnten)
' FALSE ==> Kopiervorgang Fehlerhaft
'-------------------------------------------------------------------------
Function Copy_MP3_Aus_M3U_List(sDatei_M3U_List, ByVal sZielPfad, ByVal bFlach, ByVal bRegister, ByVal nMaxAnzahl, ByVal bMP3_Protolollieren, sProtokoll, ByVal nMaxAnzahlFehlerCopy, ByVal nWarten, ByVal bFremd)
'---- Konstanten für die Funktion ------------------------------------------------------------
'---- für Registrierungsdatenbank ------------------------------------------------------------
Const REG_HKLM = "HKLM" 'HKEY_LOCAL_MACHINE
Const REG_HKCU = "HKCU" 'HKEY_CURRENT_USER
Const REG_HKCR = "HKCR" 'HKEY_CLASSES_ROOT
Const REG_HAUPTSCHLUESSEL = "HKCU\Software\VBScript\CopyMP3ausM3U\"
Const REG_OK = "Ok"
Const REG_RUN = "Run"
Const REG_PROTOKOLL = "Protokoll"
Const REG_FEHLER = "Fehler"
'---- Weitere Konstanten ---------------------------------------------------------------------
Const PROTOKOLL_DATEI = "CopyMp3.log"
Const ZUM_LESEN = 1 'Öffnen der Datei zum Lesen
Dim bEgal
Dim objFs
Dim objAusgabe
Dim bRet
Dim nAnzahl
Dim nAnzFehlerCopy
Dim sNewM3UListe
Dim bOk
Dim bFirst
Dim sLeseZeile
Dim sLeseZeile_Dateierweiterung
Dim sLeseZeile_Lw
Dim sLeseZeile_Lw_Pfad
Dim sLeseZeile_Datei
Dim sRegister
Dim sQuellPfad
Dim sZielPfadGesamt
Dim sDateien
Dim sFehler
Dim sM3U_Lw
Dim sM3U_Lw_Pfad
Dim sM3U_Datei
Dim sM3U_Dateierweiterung
bRet = True
bFirst = True
nAnzFehlerCopy = 0
if bFremd Then
' Registryeintrag für Run gestartet = 1
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_RUN, 1, "" )
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_OK, 1, "" )
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, "", "")
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "", "")
End if
'--- M3U-Listen-Datei öffnen
Set objFs = CreateObject("Scripting.FileSystemObject")
sM3U_Dateierweiterung = objFS.GetExtensionName(sDatei_M3U_List)
sM3U_Lw = objFS.GetDriveName(sDatei_M3U_List)
sM3U_Lw_Pfad = objFS.GetParentFolderName(sDatei_M3U_List)
sM3U_Datei = objFS.GetFileName(sDatei_M3U_List)
if IstLaufwerkOk(objfs.GetDriveName(sZielPfad), sFehler) then
'Ziellaufwerk ist bereit
if LCase(sM3U_Dateierweiterung) = "m3u" then
' von der Dateierweiteung eine M3U-Liste
If objfs.FileExists(sDatei_M3U_List) Then
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objAusgabe = objFs.OpenTextFile(sDatei_M3U_List,ZUM_LESEN,True)
nAnzahl = 1
Do Until objAusgabe.AtEndOfStream
'---Zeile der M3U-Liste einlesen
if nWarten > 0 Then
'für nWarten in Milisekunden den Task abgeben
WScript.Sleep nWarten
End if
sLeseZeile = LCase(objAusgabe.ReadLine)
sLeseZeile_Dateierweiterung = objFS.GetExtensionName(sLeseZeile)
if sLeseZeile_Dateierweiterung = "mp3" then
'In diese Zeile ist eine MP3-Datei beschrieben
sLeseZeile_Lw = objFS.GetDriveName(sLeseZeile)
sLeseZeile_Lw_Pfad = objFS.GetParentFolderName(sLeseZeile)
sLeseZeile_Datei = objFS.GetFileName(sLeseZeile)
if sLeseZeile_Lw = "" then
if bRegister then
sRegister = HoleRegister(sLeseZeile_Datei) & "\"
else
sRegister = ""
end if
'kein Laufwerk angegeben ==> logischer Dateiangabe
sQuellPfad = sM3U_Lw_Pfad & "\" & sLeseZeile_Lw_Pfad & "\"
if bFlach then
'alle MP3-Dateien werden in das selbe Verzeichnis kopiert
sZielPfadGesamt = sZielPfad & "\" & sRegister
sNewM3UListe = sRegister & sLeseZeile_Datei
else
'die MP3-Files werden in Ihre Ursprungs-Verzeichnisse kopiert
sZielPfadGesamt = sZielPfad & "\" & sRegister & sLeseZeile_Lw_Pfad & "\"
sNewM3UListe = sRegister & sLeseZeile
end if
else
'Laufwerk ist angegeben ==> Fester Dateiangabe
if bRegister then
sRegister = HoleRegister(sLeseZeile_Datei) & "\"
else
sRegister = ""
end if
sQuellPfad= sLeseZeile_Lw_Pfad & "\"
sZielPfadGesamt = sZielPfad & sRegister & Mid(sLeseZeile_Lw_Pfad,3) & "\"
sNewM3UListe = sZielPfadGesamt & sRegister & sLeseZeile_Datei
end if
sDateien = sLeseZeile_Datei
bOk=CopyDateien_Einfach_ohne_Dialog(sQuellPfad, sDateien, sZielPfadGesamt, sFehler)
if bOk Then
' Datei wurde ohne Fehler kopiert
nAnzFehlerCopy = 0
if bFirst then
bOk =TextdateiSchreiben( sZielPfad & "\" & sM3U_Datei, sNewM3UListe, True)
bFirst = False
else
bOk =TextdateiSchreiben( sZielPfad & "\" & sM3U_Datei, sNewM3UListe, False)
end if
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, sDateien, "")
end if
if bMP3_Protolollieren then
sProtokoll = sProtokoll & "OK Copy " & sQuellPfad & sDateien & vbNewLine
end if
'--- wenn nMaxAnzahl > 0 können nur die Maximale Anzahl von MP3-Files kopiert werden
if nMaxAnzahl > 0 then
if nAnzahl >= nMaxAnzahl then
Exit Do
end if
nAnzahl = nAnzahl +1
end if
else
' fehler beim kopieren der Datei
nAnzFehlerCopy = nAnzFehlerCopy + 1
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, "-F- " & sDateien, "")
end if
if bMP3_Protolollieren then
sProtokoll = sProtokoll & "Fehler Copy " & sQuellPfad & sDateien & vbNewLine
end if
end if
end if
if nAnzFehlerCopy > nMaxAnzahlFehlerCopy then
sProtokoll = sProtokoll & "Fehler !!! Abbruch des Kopiervorgangs durch nAnzFehlerCopy > Max Anzahl Fehlercopy"
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "Abbruch des Kopiervorgangs durch nAnzFehlerCopy > Max Anzahl Fehlercopy", "")
end if
Exit Do
end if
Loop
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, "", "")
end if
objAusgabe.close
else
bRet = False
sProtokoll = sProtokoll & "Fehler !!! M3U-Liste ist nicht Vorhanden" & vbNewLine
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "M3U-Liste ist nicht Vorhanden", "")
end if
end if
else
'keine M3U-Liste
sProtokoll = sProtokoll & "Fehler !!! keine M3U-Liste" & vbNewLine
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "keine M3U-Liste", "")
end if
bRet = False
end if
else
sProtokoll = sProtokoll & "Fehler !!! Ziellaufwerk ist nicht bereit" & vbNewLine
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "Ziellaufwerk ist nicht bereit", "")
end if
bRet = False
end if
if bFremd Then
' Registryeintrag für Run gestartet = 1
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_RUN, 0, "")
if bRet then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_OK, 1, "")
else
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_OK, 0, "")
end If
End if
Copy_MP3_Aus_M3U_List = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: RegWriteKey
'Beschreibung: Schreibt einen Eintrag in die Regestry
'ÜbergabeVariablen: sReg_Schluessel: Enthält den zu beschreibenden Schlüssel
' sReg_Argument: Entält den übergebenen Wert des Schlüssels
' sRegTyp: der Argumettyp z:B.
' "", "REG_BINARY","REG_DWORD","REG_SZ", "REG_EXPAND_SZ"
'Rückgabewert: TRUE ==> Übergabe OK
' FALSE ==> Fehler beim Scheiben in die Regestry
'-------------------------------------------------------------------------
Function RegWriteKey(ByVal sReg_Schluessel, ByVal sReg_Argument, ByVal sRegTyp)
Dim objShell
dim bRet
On Error Resume Next
Set objShell = CreateObject("WScript.Shell")
if len(sRegTyp) > 0 then
objShell.RegWrite sReg_Schluessel, sReg_Argument, sRegTyp
else
objShell.RegWrite sReg_Schluessel, sReg_Argument
end if
If Err.Number = 0 Then
bRet = True
else
bRet = False
end if
On Error Goto 0
RegWriteKey = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: CopyDateien_Einfach_ohne_Dialog
'Beschreibung: Kopiert Dateien von Quelle nach Ziel ohne Feedback über den
' Kopiervorgang beim Anwender. Es wird nur die 1. Ebene kopiert
'
' Die erforderlichen Pfade werden automatisch erzeugt
'
'ÜbergabeVariablen: sQuellPfad: Quellpfad z.B. c:\Temp\1\
' sDateien: Dateien die kopiert werden sollen z.B. *.*
' sZielPfad: Zielpfad z.B. c:\Temp\3\
' sProtokoll: Im Fehlerfall werden hier die Fehler gespeichert
'Rückgabewert: TRUE ==> Kopiervorgang Ok
' FALSE ==> Kopiervorgang Fehlerhaft
'-------------------------------------------------------------------------
Function CopyDateien_Einfach_ohne_Dialog(ByVal sQuellPfad, ByVal sDateien, ByVal sZielPfad, sProtokoll)
Dim oFs
Dim bRet
Dim bOk
dim objfs
On Error Resume Next
bRet = True
bOk=ErzeugeOrdner(sZielPfad,sProtokoll)
if bOk then
Set objfs = CreateObject("Scripting.FileSystemObject")
If Not objfs.FileExists(sZielPfad & sDateien) Then
'File noch nicht vorhanden also kopieren
Set oFs = CreateObject("Scripting.FileSystemObject")
oFs.CopyFile sQuellPfad & sDateien, sZielPfad
end if
If Err.Number = 0 Then
bRet = True
else
bRet = False
sProtokoll = sProtokoll & Err.Description & vbNewLine
end if
else
bRet = False
sProtokoll = sProtokoll & "Ordner kann nicht angelegt werden" & vbNewLine
end if
On Error Goto 0
CopyDateien_Einfach_ohne_Dialog = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: ErzeugeOrdner
'Beschreibung: Erzeugt Ordner mit beliebig vielen Unterordnern
' Es wird dabei untersucht ob das Laufwerk bereit ist
'ÜbergabeVariablen: sOrdner: String mit Laufwerk und Ordner
' sProtokoll: Im Fehlerfall werden hier die Fehler gespeichert
'Rückgabewert: TRUE ==> Ordner wurden erzeugt
' FALSE ==> Es wurden keine Ordner angelegt.
'-------------------------------------------------------------------------
Function ErzeugeOrdner(ByVal sOrdner, sProtokoll)
Dim objfs
Dim arrfeld
Dim strOrdner
Dim x
Dim sLaufwerk
Dim bRet
On Error Resume Next
bRet = False
Set objfs = CreateObject("Scripting.FileSystemObject")
nFehlerNr = 0
If Len(sOrdner) > 0 Then
sLaufwerk=objfs.GetDriveName(sOrdner)
If IstLaufwerkOk(sLaufwerk,sProtokoll) Then
arrfeld = Split(sOrdner, "\")
strOrdner = arrfeld(0) & "\"
For x = 1 To UBound(arrfeld)
strOrdner = objfs.BuildPath(strOrdner, arrfeld(x))
If Err.Number = 0 Then
bRet = True
If Not objfs.FolderExists(strOrdner) Then
objfs.CreateFolder strOrdner
If Err.Number = 0 Then
bRet = True
Else
bRet = False
sProtokoll = sProtokoll & Err.Description & vbNewLine
End If
End If
Else
bRet = False
sProtokoll = sProtokoll & Err.Description & vbNewLine
End If
Next
End If
End If
On Error Goto 0
ErzeugeOrdner = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: IstLaufwerkOk
'Beschreibung: Untersucht ob das angegebene Laufwerk bereit is
'ÜbergabeVariablen: sLw: String mit Laufwerk
' sProtokoll: Im Fehlerfall werden hier die Fehler gespeichert
'Rückgabewert: TRUE ==> Laufwerk bereit
' FALSE ==> Laufwerk nicht bereit
'-------------------------------------------------------------------------
Function IstLaufwerkOk(ByVal sLw, sProtokoll)
Dim objfs
Dim bRet
Dim objLw
On Error Resume Next
bRet = False
If sLw ="" Then
bRet =False 'kein Laufwerk angegeben
sProtokoll = sProtokoll & "Es ist kein Laufwerk angegeben" & vbNewLine
Else
Set objfs = CreateObject("Scripting.FileSystemObject")
If objfs.DriveExists(sLw) Then
'Laufwerk existiert
Set objLw = objfs.GetDrive(sLw)
If objLw.isReady Then
bRet =True 'Laufwerk ist bereit
Else
bRet =False 'Laufwerk ist nicht bereit
sProtokoll = sProtokoll & "Laufwerk ist nicht bereit" & vbNewLine
End If
Else
bRet =False 'Laufwerk existiert nicht
sProtokoll = sProtokoll & "Laufwerk exestiert nicht" & vbNewLine
End If
End If
On Error Goto 0
IstLaufwerkOk = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: TextdateiSchreiben
'Beschreibung: Schreibt einen mehrzeiligen Text in eine Textdatei
'ÜbergabeVariablen: sNameTextDatei : Name der Textdatei (mit Laufwerk und Pfad)
' sText : Text der in die Textdatei geschrieben wird
' bUeberschreiben: TRUE ==> Datei wird überschrieben
' FALSE ==> Neuer Text wird angehängt
'Rückgabewert: 0 ==> Schreiben Ok
' <> 0 ==> Fehler beim Schreiben
' FehlerCode: 0 kein Fehler
' 1 Keine Dateiname angegeben
' 2 Es wurde kein Text übergeben
' 3 Der Pfad zum Dateinamen konnte nicht erstellt werden
'-------------------------------------------------------------------------
Function TextdateiSchreiben(ByVal sNameTextDatei, ByVal sText, ByVal bUeberschreiben)
Dim nOk
Dim bOk
Dim fso
Dim sPfad
Dim objfs
Dim objAusgabe
Dim sProtokoll
On Error Resume Next
nOk = 0
If nOk = 0 Then
If sNameTextDatei = "" Then
nOk = 1
End If
End If
If nOk = 0 Then
If sText = "" Then
nOk = 2
End If
End If
'--- Falls noch nicht vorhanden die Ordner erstellen.
If nOk = 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
sPfad = fso.GetParentFolderName(sNameTextDatei) ' In Laufwerk-Pfad auftrennen
bOk=ErzeugeOrdner(sPfad,sProtokoll)
If Not bOk Then
nOk = 3
End If
End If
'--- Dateiinhalt schreiben
If nOk = 0 Then
Set objfs = CreateObject("Scripting.FileSystemObject")
If Err.Number = 0 Then
If bUeberschreiben Then
Set objAusgabe = objfs.OpenTextFile(sNameTextDatei,2,True)
If Err.Number <> 0 Then
nOk = 5
End If
Else
Set objAusgabe = objfs.OpenTextFile(sNameTextDatei,8,True)
If Err.Number <> 0 Then
nOk = 5
End If
End If
If nOk = 0 Then
objAusgabe.WriteLine sText
If Err.Number <> 0 Then
nOk = 6
End If
End If
objAusgabe.Close
Else
nOk = 4
End If
End If
On Error Goto 0
TextdateiSchreiben = nOk
End Function
'-------------------------------------------------------------------------
'Funktionsname: HoleRegister
'Beschreibung: Ermittelt aus dem Dateinamen den Register-Buchstaben
' der erste Buchstabe des Dateinamens wird dazu verwendt
' mit folgenden Regeln: A bis Z wird zu A bis Z
' Ä wird zu A, Ö wird zu O, Ü wird zu O
' 0, 1 .. 8, 9 werden zu _
' alle anderen Zeichen werden zu -
'ÜbergabeVariablen: sDateiName : Dateiname
'Rückgabewert: Registerwert _, -, A bis Z
'-------------------------------------------------------------------------
Function HoleRegister(ByVal sDateiName)
Dim sRet
Dim sErster
dim sDatei
If sDateiName = "" Then
sRet = " "
Else
sDatei = UCase(Trim(sDateiName))
If sDatei = "" Then
sRet = " "
Else
sErster = Left(sDatei,1)
Select Case sErster
Case "A","B","C","D","E","F","G","H","I","J","K","L","M"
sRet = sErster
Case "N","O","P","Q","R","S","T","U","V","W","X","Y","Z"
sRet = sErster
Case "Ä"
sRet = "A"
Case "Ö"
sRet = "O"
Case "Ü"
sRet = "U"
Case "0","1","2","3","4","5","6","7","8","9"
sRet = "_"
Case Else
sRet ="-"
End Select
End if
End If
HoleRegister = sRet
End Function
#########################################################################
>>> countdown-programmstart.hta <<<
<html>
<head>
<!--
'v6.1***************************************************
' File: countdown-programmstart.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'*******************************************************
-->
<title>Programmstart - Zeitpunkt</title>
<HTA:APPLICATION
ID="HtaID"
APPLICATIONNAME = "CountDown"
SCROLL = "no"
NAVIGABLE = "no"
MAXIMIZEBUTTON = "no"
MINIMIZEBUTTON = "no"
CAPTION = "yes"
SHOWINTASKBAR = "yes"
ICON = "http://dieseyer.de/images/boese32x32.ico"
>
<style type="text/css">
<!--
SYSMENU = "yes"
MINIMIZEBUTTON = "yes" => verhindert bei minimiertem HTA "in den Vordegrund"
background:#601010; bordeaux (weinrot) => negative Info, Achtung, Nein
background:#004030; dunkelgrün => positive Info, OK, Ja
background:#601010; dunkelblau => neutrale Info
-->
<!--
html, body { font-Size:12pt; color:#E0C000; font-family:Verdana; /* font-weight:bold; */
background:#601010;
}
a { font-size:100%; color:#FFFFFF; text-decoration:underline; }
a:active { color:red; }
a:link { color:#FFE000; }
a:visited { color:#E0C000; }
a:hover { color:red; }
a:active { color:#E0C000; }
input, select, textarea
{ color:#1d2160; font-weight:bold; }
-->
</style>
<SCRIPT language=VBScript>
Const ProgrName = "notepad"
Dim vStartZeit : vStartZeit = CDate( now() + CDate( "01:01:00" ) )
Dim vAnzeigeNeu
Dim TastTaste ' um [F5] für HTA neu starten abzufangen
Dim Tst, Txt, Anwendung, i
Dim MsgPop : MsgPop = "5"
'**************************************************************
Sub AnzeigeNeu()
'**************************************************************
' Aufruf durch: vAnzeigeNeu = window.setInterval("AnzeigeNeu()", 250, "VBScript")
' aus vStartZeit die Sekunden auf ":00" setzen
vStartZeit = FormatDateTime( vStartZeit, vbShortDate ) & " " & FormatDateTime( vStartZeit, vbShortTime )
vRestZeit = FormatDateTime( CDate( CDate( vStartZeit ) - now() ) , vbLongTime )
Tst = DateDiff( "s", now(), CDate( vStartZeit ) )
Tst = FormatNumber( Tst, 0, 0, 0, -2 ) ' FormatNumber(Ausdruck[, AnzDezimalstellen[, FührendeNull[, KlammernFürNegativeWerte[, ZiffernGruppieren]]]])
If Tst <= 1 Then : vStartZeit = "" : self.close : Exit Sub
Ttt = "<br>CountDown bis zum Start des Programms => <b>""" & ProgrName & """</b><br>"
Ttt = "<br>CountDown bis zum Programmstart von <br><br><b> => """ & ProgrName & """ <=</b><br>"
document.all.idErsteZeile.innerHTML = Ttt
Ttt = vRestZeit ' vRestZeit zur Anzeige anpassen
If InStr( "x" & vRestZeit, "x00:" ) > 0 Then Ttt = Replace( "x" & vRestZeit, "x00:", "" ) & " min"
top.document.title = Replace( Replace( "x" & vRestZeit, "x00:00:", "00:" ), "x", "" ) & " bis Programmstart"
If Tst > 175 Then ' für unterschiedliche Anzeigeformat
document.all.idStartZeit.innerHTML = "Für den Programmstart ist der <b>" & vStartZeit & "</b> gesetzt - das ist in " & vRestZeit & " h."
document.all.idStartRest.innerHTML = "Programmstart in " & Ttt & "<br>"
Else
document.all.idStartZeit.innerHTML = "Für den Programmstart ist der <b>" & vStartZeit & "</b> gesetzt - das ist in " & Tst & " s."
document.all.idStartRest.innerHTML = "Programmstart in " & Tst & " sec<br>"
'' top.document.title = Tst & " s bis Programmstart"
End If
' In der letzten Stunde vor Ablauf wird diese HTA in den Vordergrund geholt - zur Erinnerung
' ~~~~~~~~~~~~~~~~~~~~~
' 1h, 1/2h, 1/4h, 5min und 1min vor Ablauf
Ttt = "-OK"
Txt = Fix( DateDiff( "n", now(), CDate( vStartZeit ) ) )
If MsgPop = "5" AND Txt < 61 Then MsgPop = "4" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "4" AND Txt < 31 Then MsgPop = "3" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "3" AND Txt < 21 Then MsgPop = "2" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "2" AND Txt < 11 Then MsgPop = "1" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "1" AND Txt < 4 Then MsgPop = "0" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If DateDiff( "s", now(), CDate( vStartZeit ) ) < 30 Then Ttt = "OK"
i = i + 1 : If i < 20 Then Exit Sub
If not Ttt = "OK" Then Exit Sub
i = 0
window.clearInterval( vAnzeigeNeu ) ' damit die Aktualisierung der Anzeige nicht beim In-Den-Vordergrund-Bringen dazwischen funkt
' In dem VBS wird mit AppActivate das startende HTA in den Vordergrund geholt.
' Dieser Umweg ist notwendig, da folgende Aufrufe nicht das gewünschte Ergebnis brachten:
'' document.focus()
'' self.focus
'' window.focus
'' self.setActive - gibst nicht
Dim progr : progr = top.document.title
Dim Datei : Datei = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\temp-.vbs"
Dim FileOut : Set FileOut = CreateObject("Scripting.FileSystemObject").CreateTextFile( Datei , true)
FileOut.WriteLine "' " & now() & " )"
FileOut.WriteLine "Tst = CreateObject(""WScript.Shell"").AppActivate( ""00:"" )"
FileOut.WriteLine "WScript.Sleep 333"
FileOut.WriteLine "Tst = CreateObject(""WScript.Shell"").AppActivate( ""00:"" )"
FileOut.WriteLine "WScript.Sleep 333"
FileOut.WriteLine "CreateObject(""WScript.Shell"").SendKeys""{F5}"""
FileOut.WriteLine "Set fso = CreateObject(""Scripting.FileSystemObject"")"
FileOut.WriteLine "If fso.FileExists( WScript.ScriptFullName ) Then fso.DeleteFile( WScript.ScriptFullName )"
' FileOut.WriteLine "WScript.Sleep 333"
' FileOut.WriteLine "WScript.Sleep 1000"
' FileOut.WriteLine "MsgBox Tst & "" - E N D E - "", , WScript.ScriptName"
FileOut.Close
Set FileOut = nothing
window.setTimeout "ProgrRun('" & Datei & "')", 333 ' warten bis VBS 'richtig' geschrieben ist
End Sub ' AnzeigeNeu()
'**************************************************************
Sub ProgrRun( DateiX )
'**************************************************************
CreateObject("WScript.Shell").Run DateiX , , True
window.setTimeout "Window_OnLoad()", 333 ' warten bis window.clearInterval 'richtig' wirkt
End Sub ' ProgrRun( DateiX )
'**************************************************************
Sub window_onbeforeunload
'**************************************************************
' window.event.returnValue = "> > > > > Mit dem Schließen dieser Anwendung wird das Programm gestartet! < < < < <"
' sollte [F5] gedrückt worden sein (beendet das HTA und lädt es neu)
If TastTaste = 116 Then Call RegKeySchreiben( vStartZeit ) : Exit Sub
CreateObject("WScript.Shell").Run ProgrName
End Sub ' window_onbeforeunload
'**************************************************************
Sub RegKeySchreiben( Wert ) ' http://dieseyer.de/scr/wmi-regkeywrite.vbs
'**************************************************************
Dim KeyPath : KeyPath = "SOFTWARE\dieseyer.de\Enviroment"
Dim KeyKey : KeyKey = "EndeZeit"
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Const HKLM = &H80000002
' Inhalt schreiben
oReg.CreateKey HKLM,KeyPath
oReg.SetStringValue HKLM,KeyPath,KeyKey,Wert
End Sub ' RegKeySchreiben( Wert )
'**************************************************************
Function RegKeyLesen() ' http://dieseyer.de/scr/wmi-regkeywrite.vbs
'**************************************************************
Dim KeyPath : KeyPath = "SOFTWARE\dieseyer.de\Enviroment"
Dim KeyKey : KeyKey = "EndeZeit"
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Const HKLM = &H80000002
' Inhalt lesen
oReg.GetExpandedStringValue HKLM,KeyPath,KeyKey,KeyInh
RegKeyLesen = KeyInh
Call RegKeySchreiben( "" )
End Function ' RegKeyLesen
'**************************************************************
Sub Window_OnLoad
'**************************************************************
Dim Tst
' window.moveto Links, Oben
window.moveto 50, 50 ' Position
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 820, 600
Tst = ""
Tst = RegKeyLesen()
If not Tst = "" Then Call StartZeitTest( Tst ) ' alte vStartZeit aus Reg verwendbar?
Call RegKeySchreiben( "" )
Call AnzeigeNeu()
Call ZeitAuswahl()
vAnzeigeNeu = window.setInterval("AnzeigeNeu()", 222, "VBScript")
End Sub ' Window_OnLoad
'**************************************************************
Sub ZeitAuswahl()
'**************************************************************
TastEing = 13
Dim Txt
Txt = Txt & " <Span style=""font-size:12pt""> "
Txt = Txt & " <fieldset><Legend align=""Center""> Zeit bis Programmstart verkürzen: </legend> "
Txt = Txt & " </Span><Span style=""font-size:10pt""> "
Txt = Txt & " <br> <input Type=""text"" Name=""neueZeit"" Value="" "" > "
Txt = Txt & " <br><br> "
Txt = Txt & " <p align=""Left""> Erlaubte Eingaben: <br> "
Txt = Txt & " <b>3,5h</b> Programmstart in 3 Stunden und 30 Minuten <br> "
Txt = Txt & " <b>120min</b> Programmstart in 120 Minuten <br> "
Txt = Txt & " <b>2:15</b> Programmstart um 2 Uhr und 15 Minuten (oder 14:15) "
Txt = Txt & " <p> "
document.all.AnzeigeHTA.innerHTML = Txt
End Sub ' ZeitAuswahl()
'**************************************************************
Sub document_onKeyDown
'**************************************************************
TastTaste = window.event.keyCode
If TastTaste = 13 Then Call neuesEnde()
End Sub
'**************************************************************
Sub neuesEnde()
'**************************************************************
Call StartZeitTest( UCase( Document.All.neueZeit.Value ) )
End Sub ' neuesEnde()
'**************************************************************
Sub StartZeitTest( Tst )
'**************************************************************
Dim errTst
Dim X : X = "-"
' MsgBox Tst, , "256 :: "
On Error Resume Next
err.Clear : If InStr( Tst, ":" ) > 0 Then Tst = CDate( Tst ) : If err.Number = 0 Then X = "+"
err.Clear : If InStr( Tst, "M" ) > 0 Then Tst = DateAdd( "n", Replace( Tst, "M" , "" ) , now() ) : If err.Number = 0 Then X = "+"
err.Clear : If InStr( Tst, "MIN" ) > 0 Then Tst = DateAdd( "n", Replace( Tst, "MIN" , "" ) , now() ) : If err.Number = 0 Then X = "+"
err.Clear : If InStr( Tst, "H" ) > 0 Then Tst = DateAdd( "n", Replace( Tst, "H" , "" ) * 60 , now() ) : If err.Number = 0 Then X = "+"
If X = "-" Then MsgBox "Ungültige Eingabe!", 48, "267 :: " : Exit Sub
On Error GoTo 0
' MsgBox Tst, , "271 :: "
' If Tst < DateAdd( "d", -2, vStartZeit ) Then MsgBox Tst & vbCRLF & CDate( date() & " " & Tst ): Tst = CDate( date() & " " & Tst )
If Tst < DateAdd( "d", -2, vStartZeit ) Then Tst = CDate( date() & " " & Tst )
If Tst < now() Then Tst = DateAdd( "h", 12 , Tst )
If Tst < now() Then Tst = DateAdd( "h", 12 , Tst )
If Tst < now() Then Tst = DateAdd( "h", 12 , Tst )
' If DateDiff( "h", Tst, now() ) > 12 Then MsgBox Tst & vbCRLF & DateAdd( "h", Tst , -12 ) & vbCRLF & vStartZeit : Tst = DateAdd( "h", Tst , -12 )
If DateDiff( "h", Tst, now() ) > 12 Then Tst = DateAdd( "h", Tst , -12 )
' MsgBox Tst & vbCRLF & vStartZeit
If Tst > CDate( vStartZeit ) Then MsgBox vbTab & "Ungültige Eingabe!" & vbCRLF & vbCRLF & "Die Zeit bis zum Programmstart kann nur verkürzt werden!", 48, "284 :: ==> " & Tst : Call ZeitAuswahl() : Exit Sub
vStartZeit = Tst
Call AnzeigeNeu()
Call ZeitAuswahl()
End Sub ' StartZeitTest( Tst )
</SCRIPT>
</HEAD>
<BODY>
<form>
<center>
<span style="font-size:20pt;" ID=idErsteZeile> </span>
<br><br><span style="font-size:36pt;font-weight:bold;" ID=idStartRest></span><br><br>
<b><u> A C H T U N G</u> =></b> Mit dem Schließen dieses Fensters wird das Programm <u>sofort</u> gestartet!
<br><br>
<span ID=idStartZeit></span>
<br><br>
<table align="Center" border="0" cellspacing="20px" width="066%">
<tr >
<td align="Center" cellspacing="70%" >
<div ID=AnzeigeHTA >
</td>
</tr>
</table>
</form>
</BODY>
</html>
#########################################################################
>>> cpu-last-test.vbs <<<
'12345678x
' x
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' On Error Resume Next
Dim oArgs : set oArgs = Wscript.Arguments
Dim PauseZeit : PauseZeit = 23 ' Pause zw. den einzelnen Messungen
Dim TestAnzah : TestAnzah = 200
strComputer = "."
strComputer = "SRV01.BEIMIR.LOKAL"
Call Test2()
WScript.Quit
If oArgs.Count = 0 then strComputer = "."
strComputer = oArgs.item(i)
If not WMIpingOK( strComputer ) Then MsgBox "PCname """ & strComputer & " ist nicht erreichbar!", , "0024 :: ENDE - " & Wscript.ScriptName : WScript.Quit
i = 0
Do
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor")
i = i + 1
For Each objItem in colItems
' Wscript.Echo i & " Address Width: " & objItem.AddressWidth
' Wscript.Echo i & " Architecture: " & objItem.Architecture
' Wscript.Echo i & " Availability: " & objItem.Availability
' Wscript.Echo i & " CPU Status: " & objItem.CpuStatus
Tst = Tst & vbTab & objItem.LoadPercentage
' Wscript.Echo i & " Data Width: " & objItem.DataWidth
' Wscript.Echo i & " Description: " & objItem.Description
' Wscript.Echo i & " Device ID: " & objItem.DeviceID
' Wscript.Echo i & " Ext Clock: " & objItem.ExtClock
' Wscript.Echo i & " Family: " & objItem.Family
' Wscript.Echo i & " L2 Cache Size: " & objItem.L2CacheSize
' Wscript.Echo i & " L2 Cache Speed: " & objItem.L2CacheSpeed
' Wscript.Echo i & " Level: " & objItem.Level
' Wscript.Echo i & " Load Percentage: " & objItem.LoadPercentage
' Wscript.Echo i & " Manufacturer: " & objItem.Manufacturer
' Wscript.Echo i & " Maximum Clock Speed: " & objItem.MaxClockSpeed
' Wscript.Echo i & " Name: " & objItem.Name
' Wscript.Echo i & " PNP Device ID: " & objItem.PNPDeviceID
' Wscript.Echo i & " Processor Id: " & objItem.ProcessorId
' Wscript.Echo i & " Processor Type: " & objItem.ProcessorType
' Wscript.Echo i & " Revision: " & objItem.Revision
' Wscript.Echo i & " Role: " & objItem.Role
' Wscript.Echo i & " Socket Designation: " & objItem.SocketDesignation
' Wscript.Echo i & " Status Information: " & objItem.StatusInfo
' Wscript.Echo i & " Stepping: " & objItem.Stepping
' Wscript.Echo i & " Unique Id: " & objItem.UniqueId
' Wscript.Echo i & " Upgrade Method: " & objItem.UpgradeMethod
' Wscript.Echo i & " Version: " & objItem.Version
' Wscript.Echo i & " Voltage Caps: " & objItem.VoltageCaps
Next
If Len( i ) = 1 Then Tst = strComputer & vbTab & "00" & i & ":" & Tst & vbTab & Now()
If Len( i ) = 2 Then Tst = strComputer & vbTab & "0" & i & ":" & Tst & vbTab & Now()
If Len( i ) = 3 Then Tst = strComputer & vbTab & "" & i & ":" & Tst & vbTab & Now()
Wscript.Echo Tst : Tst = ""
' MsgBox WSCript.ScriptFullName
' WScrip.Sleep 1*1000
If not fso.FileExists( WSCript.ScriptFullName ) Then Exit Do
WScript.Sleep 1
Set objWMIService = nothing
Set colItems = nothing
Loop
MsgBox "ENDE"
'**************************************************************
Function WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
' Aufruf z.B.: If not WMIpingOK( ZielPC ) Then MsgBox ZielPC & " ist nicht erreichbar." : WScript.Quit
Dim objPing, objStatus
WMIpingOK = True
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & PCName & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
WScript.Echo("machine " & machine & " is not reachable")
WMIpingOK = False
End If
Next
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
Function Test()
'**************************************************************
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
set objRefresher = CreateObject("WbemScripting.Swbemrefresher")
Set objProcessor = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfOS_Processor").objectSet
intThresholdViolations = 0
objRefresher.Refresh
Do
For each intProcessorUse in objProcessor
Tst = intProcessorUse.PercentProcessorTime
If not IsNull( Tst ) Then MsgBox Tst & " - " & intProcessorUse.Description
' If intProcessorUse.PercentProcessorTime > 90 Then
' intThresholdViolations = intThresholdViolations + 1
' If intThresholdViolations = 10 Then
' intThresholdViolations = 0
' Wscript.Echo "Processor usage threshold exceeded."
' End If
' Else
' intThresholdViolations = 0
' End If
Next
' Wscript.Sleep 6000
objRefresher.Refresh
Loop
End Function ' Test()
'**************************************************************
Function Test2()
'**************************************************************
Dim FileOut : Set FileOut = fso.OpenTextFile( Replace( WSCript.ScriptFullName, ".vbs", ".log" ), 8, true)
fileOut.WriteLine( "0103 :: " & now() & vbTab & "Skriptstart auf " & strComputer )
' WMI bereit stellen
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Dim objRefresher : Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Dim colItems : Set colItems = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfProc_Process").objectSet
Dim objItem
objRefresher.Refresh
' wscript.sleep( 3*1000 )
n = 1
Do
fileOut.WriteLine( n & ". Durchlauf folgt" & vbTab & Now() & " (" & Timer() & ")" )
Set CpuItems = GetObject("winmgmts:\\" & strComputer & "\root\cimv2").ExecQuery("Select * from Win32_Processor")
Tst = "" : i = 0
For Each objItem in CpuItems
i = i + 1
Tst = Tst & vbTab & objItem.LoadPercentage
Next
Set objWMIService = nothing
Set CpuItems = nothing
fileOut.WriteLine( Tst & vbTab & " <= ist %-Auslastung jeder der " & i & " CPUs" & vbTab & Now() & " (" & Timer() & ")" )
For Each objItem in colItems
' If InStr( LCase( objItem.Name ), LCase( Progr ) ) > 0 Then
If objItem.PercentProcessorTime > 0 Then
Txt = UCase( objItem.Name )
If Txt <> "_TOTAL" AND Txt <> "IDLE" Then
' If Txt <> "IDLE" Then
' Txt = Txt & "Handle Name: " & objItem.Name & vbTab
' Txt = Txt & "Handle Count: " & objItem.HandleCount & vbTab ' Eine Handleanzahl, die kontinuierlich zunimmt, ohne jemals abzunehmen, weist oft darauf hin, dass nicht der gesamte reservierte Speicher freigegeben wird.
' Txt = Txt & "Percent Processor Time: " & objItem.PercentProcessorTime & vbTab ' % CPU-Last
' Txt = Txt & "Working Set: " & objItem.WorkingSet & vbTab ' verw. RAM ?
' Txt = objItem.PercentProcessorTime & " - " & objItem.WorkingSet & " - " & objItem.HandleCount & " - " & objItem.Name
Txt = objItem.PercentProcessorTime & vbTab & Right( "00000000000000" & objItem.WorkingSet, 12 ) & vbTab & objItem.HandleCount & vbTab & objItem.Name
' fileOut.WriteLine( now() & vbTab & Txt ) : Txt = ""
fileOut.WriteLine( Txt )
End If
End If
Next
fileOut.WriteLine( n & ". Durchlauf erledigt" & vbTab & Now() & " (" & Timer() & ")" )
wscript.sleep( PauseZeit * 1000 ) : n = n + 1 : If n > TestAnzah Then Exit Do
objRefresher.Refresh
Loop
' 2 000031109120 367 w3wp
fileOut.WriteLine( "% " & vbTab & "[ Memory ]" & vbTab & "Handle" & vbTab & "Name" )
fileOut.WriteLine( "0136 :: " & now() & vbTab & "Skriptende auf " & strComputer & vbCRLF )
fileOut.Close
Set FileOut = Nothing ' Datei schließen
End Function ' Test2()
#########################################################################
>>> 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 ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 ) ' 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 )
#########################################################################
>>> crlf-entfernen.vbs <<<
'v5.1********************************************************
' File: crlf-entfernen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' entfernt alle CR, LF und CRLF aus einer Datei.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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
' Datei komplett einlesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
Text = FileIn.ReadAll
FileIn.Close
Set FileIn = nothing
' Inhalt bearbeiten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox Text
Text = Replace( Text, vbCRLF , "" )
Text = Replace( Text, vbCRLF , "" )
Text = Replace( Text, vbCR , "" )
Text = Replace( Text, vbCR , "" )
Text = Replace( Text, vbLF , "" )
Text = Replace( Text, vbLF , "" )
MsgBox Text
' (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
FileOut.Write( Text )
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 )
#########################################################################
>>> datei-in-datum-sichern.vbs <<<
'*** v4.7 *** www.dieseyer.de ******************************
' File: datei-in-datum-sichern.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Skript überprüft, ob es eine bestimmte Datei gibt, kopiert
' diese in ein Sicherungsverzeichnis und benennt sie dabei
' um - der neue Dateiname ist der Kopierzeitpunkt.
' Die alte Datei wird gelöscht.
'***********************************************************
Option Explicit
Dim fso
Dim Dateiname, ZielVerz, Intervall, i, text
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dateiname = "c:\temp\wichtig.txt" ' Dateiname mit komplettem Pfad
ZielVerz = "d:\wichtige" '
ZielVerz = ZielVerz & "\"
Intervall = 10 ' Testintervall in Sekunden
i = 0
Do
if fso.FileExists( Dateiname ) Then
i = i +1
fso.CopyFile Dateiname, ZielVerz & DatumZeit & ".txt"
Fso.DeleteFile Dateiname
Text = MsgBox( Dateiname & vbCRLF & vbCRLF & "zum " & i &". mal gefunden - Skript beenden?", 4+256, WScript.ScriptName)
If Text = vbYes then Exit Do
End If
if fso.FileExists( fso.GetBaseName( WScript.ScriptName) & ".end" ) Then Exit Do
WScript.Sleep Intervall * 1000
Loop
MsgBox Dateiname & vbCRLF & vbCRLF & "zum " & i &". mal gefunden - Skript - Ende.", , WScript.ScriptName
if fso.FileExists( fso.GetBaseName( WScript.ScriptName) & ".end" ) Then fso.DeleteFile( fso.GetBaseName( WScript.ScriptName) & ".end" )
WScript.Quit
'*** v4.7 *** www.dieseyer.de ******************************
Function DatumZeit
'***********************************************************
' gibt ein Zeichenfolge zurück, die Datum / Zeit enthält
' und als Dateiname / Verzeichnisnae verwendet werden kann
Dim Zeit
Zeit = now()
' zweistellige Jahreszahl
DatumZeit = Right(Year(Zeit),2)
' zweistellige Monatszahl
If Len(Month(Zeit)) = 1 then DatumZeit = DatumZeit & "-0" & Month(Zeit)
If not Len(Month(Zeit)) = 1 then DatumZeit = DatumZeit & "-" & Month(Zeit)
' zweistellige Tageszahl
If Len(Day(Zeit)) = 1 then DatumZeit = DatumZeit & "-0" & Day(Zeit)
If not Len(Day(Zeit)) = 1 then DatumZeit = DatumZeit & "-" & Day(Zeit)
' zweistellige Stundezahl
If Len(Hour(Zeit)) = 1 then DatumZeit = DatumZeit & "_0" & Hour(Zeit)
If not Len(Hour(Zeit)) = 1 then DatumZeit = DatumZeit & "_" & Hour(Zeit)
' zweistellige Minutenzahl
If Len(Minute(Zeit)) = 1 then DatumZeit = DatumZeit & "'0" & Minute(Zeit)
If not Len(Minute(Zeit)) = 1 then DatumZeit = DatumZeit & "'" & Minute(Zeit)
' zweistellige Sekundenzahl
If Len(Second(Zeit)) = 1 then DatumZeit = DatumZeit & "'0" & Second(Zeit)
If not Len(Second(Zeit)) = 1 then DatumZeit = DatumZeit & "'" & Second(Zeit)
End Function ' DatumZeit
#########################################################################
>>> datei-verzeichnis-liste.vbs <<<
'v3.6*****************************************************
' File: Datei-Verzeichnis-Liste.vbs
' Autor: dieseyer@gmx.de
' http://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 ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 " & i+1 & " 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 " & i & " Verzeichnisse:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
#########################################################################
>>> dateialshtml.vbs <<<
'v3.7********************************************************
' File: DateiAlsHtml.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 ) ' 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 ()
#########################################################################
>>> dateiauswahl-txtzeigen.hta <<<
<html>
<head>
<title>Load Computers Sample</title>
<HTA:APPLICATION
ID="objTestHTA"
APPLICATIONNAME="Load Computers Sample"
SCROLL="yes"
SINGLEINSTANCE="yes"
WINDOWSTATE="maximize"
>
</head>
<SCRIPT Language="VBScript">
Sub LoadComputers
Set objDialog = CreateObject("UserAccounts.CommonDialog")
objDialog.Filter = "Text Files|*.txt|All Files|*.*"
objDialog.FilterIndex = 1
objDialog.InitialDir = "C:\Scripts"
intResult = objDialog.ShowOpen
If intResult = 0 Then
Exit Sub
End If
For Each objOption in AvailableComputers.Options
objOption.RemoveNode
Next
ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile _
(objDialog.FileName, ForReading)
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
Set objOption = Document.createElement("OPTION")
objOption.Text = strLine
objOption.Value = strLine
AvailableComputers.Add(objOption)
Loop
objFile.Close
End Sub
</SCRIPT>
<body bgcolor="buttonface">
<input id=runbutton class="button" type="button" value="Load Computers"
name="run_button" onClick="LoadComputers"><p>
<select size="10" name="AvailableComputers" style="width:300" >
</select>
</body>
</html>
#########################################################################
>>> dateienaltdelete-2.vbs <<<
'v4.7********************************************************
' File: dateienaltdelete-2.vbs
'
' Autor: hos@ctmagazin.de
' http://www.heise.de/ct/faq/hotline/03/21/09.shtml
'
' Löscht alle Dateien, die seit einem bestimmten Datum
' nicht mehr geändert wurden
'
'************************************************************
' hier eigenen Bedürfnissen anpassen
Verzeichnis = "C:\Bilder" ' Hier wird gelöscht!
Aufheben = 31 ' Anzahl der Tage
' Ende der Anpassungen
Set fso = CreateObject("Scripting.FileSystemObject")
Set ordner = fso.GetFolder(Verzeichnis)
heute = Date()
DeleteInFolder(ordner)
Sub DeleteInFolder(ordner)
Set dateien = ordner.Files
' Alle Dateien in diesem Ordner abklappern
For Each datei In dateien
If datei.DateLastModified < (heute - Aufheben) Then
datei.Delete
End If
Next
Set untere = ordner.SubFolders
'Unterordner abklappern, DeleteInFolder rekursiv aufrufen
For Each unter In untere
DeleteInFolder(unter)
Next
End Sub
#########################################################################
>>> dateienaltdelete-3.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienaltdelete-3.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ursprungsskript:
' dateienalteliste.vbs
' mit der Prozedur AlteDateien( arrDateiLst, Alter, ZeitType )
'
' Erweiterungen:
' - die Prozedur "DateiListeLoeschen arrDateiLst"
' - Parameter um das Löschen zu aktivieren/deaktivieren (LoeschenAktiv = "YES")
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const Alter = 55
Const ZeitType = "d"
Const LoeschenAktiv = "-YES"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "039 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "040 :: LogDatei: " & LogDatei
LogEintrag "041 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "043 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "051 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
LogEintrag "055 :: arrDateiAlt = AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrDateiAlt = AlteDateien( arrDateiLst, Alter, ZeitType )
AlteDateien arrDateiLst, Alter, ZeitType
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateiListeLoeschen arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "075 :: " & WScript.ScriptName
LogEintrag "077 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateiListeLoeschen( arrDateiLst )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim i, m, n, z, Tst
i = 0 : m = 0 : n = 0 : z = 0
LogEintrag "089 :: Start der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
If LoeschenAktiv = "YES" Then LogEintrag "091 :: LÖSCHEN IST AKTIV - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
If LoeschenAktiv <> "YES" Then LogEintrag "092 :: LÖSCHEN IST DEAKTIVIERT - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
' Dateinamen des Arrays testen und Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
On Error Resume Next
Tst = " - "
If LoeschenAktiv = "YES" Then fso.DeleteFile arrDateiLst( i )
If LoeschenAktiv <> "YES" Then LogEintrag "102 :: Datei( " & i & " ) wird NICHT gelöscht: " & arrDateiLst( i )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
LogEintrag "108 :: Datei( " & i & " ) nicht löschbar: " & arrDateiLst( i ) & " " & Tst
z = z + 1
Else
If LoeschenAktiv = "YES" Then n = n + 1 : LogEintrag "111 :: Datei( " & i + 1 & " ) gelöscht: " & arrDateiLst( i )
End If
Else
If Len( arrDateiLst( i ) ) > 3 Then
LogEintrag "115 :: Datei( " & i & " ) fehlt (kann daher nicht gelöscht werden): " & arrDateiLst( i )
Else
m = m + 1
' LogEintrag "118 :: Datei( " & i & " ): " & arrDateiLst( i )
End If
End If
Next
LogEintrag "123 :: " & n & " von " & i & " Dateien gelöscht."
LogEintrag "124 :: " & z & "x ist ein Fehler beim Löschen einer Datei aufgetreten."
LogEintrag "125 :: " & m & " Arrayeinträge waren leer bzw. enthielten keinen gültigen Dateinamen."
LogEintrag "126 :: Ende der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
End Function ' DateiListeLoeschen( arrDateiLst )
'*** v7.C *** www.dieseyer.de ****************************
Function AlteDateien( arrDateiLst, Alter, ZeitType )
'*********************************************************
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst, Ttt, i
Dim ZeitBezug : ZeitBezug = "NACH"
LogEintrag "164 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' 'ZeitBezug' auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Left( Alter, 1 ) = "-" Then ZeitBezug = "VOR" : Alter = Mid( Alter, 2 )
If Left( Alter, 1 ) = "+" Then ZeitBezug = "NACH" : Alter = Mid( Alter, 2 )
If ZeitType = "VOR" Then ZeitBezug = "VOR"
If ZeitType = "NACH" Then ZeitBezug = "NACH"
LogEintrag "173 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' Prüfen, ob der Inhalt von 'Alter' verwendbar ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not IsDate( Alter ) Then Alter = CLng( Alter )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
' Alter enthält weder ein Datum noch eine Zahl; Alter ist ungültig!
WSHShell.Popup "Falscher Parameter für ""Alter"": " & vbCRLF & vbTab & "'" & Alter & "' führt zu" & vbCRLF & vbTab & Tst, 30, "183 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
LogEintrag "186 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
Tst = "-DATUM"
If InStr( Alter, ":" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "/" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "-" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "." ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If Tst <> "DATUM" Then Alter = CLng( Alter)
LogEintrag "193 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbTab & Tst
' Dateinamen des Arrays testen und ggf. im Array löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
Tst = fso.GetFile( arrDateiLst( i ) ).DateLastModified
Ttt = DateDiff( ZeitType, Tst, now() )
If IsDate( Alter ) Then
' arrDateiLst( i ) = Clng( Tst - Alter ) & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Tst - Alter < 0 Then arrDateiLst( i ) = "" ' & "N " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Tst - Alter > 0 Then arrDateiLst( i ) = "" ' & "V " & arrDateiLst( i )
Else
' arrDateiLst( i ) = Ttt & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Ttt < Alter Then arrDateiLst( i ) = "" ' & "n " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Ttt > Alter Then arrDateiLst( i ) = "" ' & "v " & arrDateiLst( i )
End If
'DateDiff(Intervall, Datum1, Datum2 [,ErsterWochentag[,ErsteWocheimJahr]] )
'Die Syntax der DateDiff-Funktion besteht aus folgenden
Next
End Function ' AlteDateien( arrDateiLst, Alter, ZeitType )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "263 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "264 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "282 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "291 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> 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
#########################################################################
>>> dateienaltdeletetyp-2.vbs <<<
'*** v10.8 *** www.dieseyer.de ******************************
'
' Datei: DateienAltDeleteTyp.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Löscht alle Dateien mit einer bestimmten Erweiterung, die
' seit einem bestimmten Datum nicht mehr geändert wurden.
' (Vergl. AcronisAlteTibEntfernen.vbs)
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Pfad, Alter, DateiTyp
DateiTyp = "rex"
DateiTyp = "cmd"
DateiTyp = "bak"
DateiTyp = "vbs"
Pfad = "d:\setup"
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet, Skript wird also auch gelöscht
Pfad = "c:\temp"
Alter = 365*7 ' Dateien, die seit xxx Tagen nicht geändert wurden
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( " ", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup vbTab & "= = = S T A R T = = =", 2, "042 :: " & WScript.ScriptName, vbInformation
Trace32Log "043 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "044 :: LogDatei: " & LogDatei, 1
Trace32Log "045 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "046 :: Angemeldeter User: " & WSHNet.UserName, 1
AlteDateienErweiterung Pfad, Alter, DateiTyp
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.Popup vbTab & "= = = E N D E = = =", 2, "051 :: " & WScript.ScriptName, vbInformation
Trace32Log "052 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v10.8 *** www.dieseyer.de *****************************
Function AlteDateienErweiterung( Verz, Alter, DateiErw )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oFiles, Datei, Txt, errTst, i, n
DateiErw = UCase( DateiErw )
i = 0 : n = 0
Trace32Log "067 :: Alte Dateien sollen gelöscht werden - Verzeichnis: " & Verz, 1
Trace32Log "068 :: Alte Dateien sollen gelöscht werden - Dateierweiterung (Extension): " & DateiErw, 1
Trace32Log "069 :: Alte Dateien sollen gelöscht werden - min. Alter der zu löschenden Dateien: " & Alter, 1
Trace32Log "070 :: Alte Dateien sollen gelöscht werden - Änderungsdatum der Dateien vor: " & FormatDateTime( now() - Alter, 2), 1
if not fso.FolderExists( Verz ) then
WSHShell.Popup vbTab & "Verzeichnis existiert nicht:" & vbCRLF & vbCRLF & Verz, 5, "073 :: " & WScript.ScriptName, 4096 + vbCritical
Trace32Log "074 :: Verzeichnis existiert nicht: " & Txt, 3
Exit Function
End If
Trace32Log "078 :: ", 1
Set oFiles = fso.GetFolder( Verz ).Files
For Each Datei In oFiles
' Trace32Log "083 :: Datei wird geprüft: " & Datei.Path, 1
' Trace32Log "084 :: Letzte Dateiänderung: " & Datei.DateLastModified, 1
' Trace32Log "085 :: min. ALter: " & FormatDateTime( now() - Alter, 2) & " - " & Alter & "d", 1
' Trace32Log "086 :: ALtersunterschied zu heute: " & DateDiff( "d" , Datei.DateLastModified, Date() ) & "d", 1
' Trace32Log "087 :: Daeierweiterung: " & UCase( fso.GetExtensionName( Datei.Path ) ), 1
If not UCase( fso.GetExtensionName( Datei.Name) ) = DateiErw Then
Trace32Log "090 :: Daeierweiterung stimmt nicht: " & UCase( fso.GetExtensionName( Datei.Path ) ), 2
Else
' Trace32Log "092 :: " & DateDiff( "d" , Datei.DateLastModified, Date() ) & " > " & Alter , 1
If DateDiff( "d" , Datei.DateLastModified, Date() ) > Alter Then ' vor dem Alter geänderte Dateien
Txt = Datei.path ' nach dem Löschen von Datei.Path ist, fehlt Datei.Path
' Trace32Log "097 :: Datei soll gelöscht werden: " & Txt, 1
On Error Resume Next
fso.DeleteFile Txt, True
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
if Len( errTst ) < 5 Then
Trace32Log "104 :: Gelöscht: " & Txt, 1
i = i + 1
Else
Trace32Log "107 :: Nicht löschbar: " & Txt & " - " & errTst, 3
n = n + 1
End if
End if
End If
Next
Set oFiles = nothing
Set fso = nothing
Trace32Log "118 :: ", 1
Trace32Log "119 :: " & i & " Dateien sind gelöscht.", 1
Trace32Log "120 :: " & n & " Dateien wurden nicht gelöscht (wegen fehler).", 1
End Function ' AlteDateienErweiterung( Verz, Alter, DateiErw )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "209 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "210 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> dateienaltdeletetyp.vbs <<<
'*** v4.6 *** www.dieseyer.de *******************************
'
' Datei: DateienAltDeleteTyp.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Löscht alle Dateien mit einer bestimmten Erweiterung, die
' seit einem bestimmten Datum nicht mehr geändert wurden
'
'************************************************************
Option Explicit
Dim Pfad, Alter, DateiTyp
DateiTyp = "rex"
DateiTyp = "cmd"
DateiTyp = UCase(DateiTyp)
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
'*** v4.6 *** www.dieseyer.de *******************************
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
if UCase( fso.GetExtensionName(i.Name) ) = DateiTyp then
fso.DeleteFile i.path, True
End if
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 (Pfad, Alter) ' Ende
#########################################################################
>>> dateienalteliste.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienalteliste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const Alter = 955
Const ZeitType = "d"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "056 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "057 :: LogDatei: " & LogDatei
LogEintrag "058 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "060 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "068 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
LogEintrag "072 :: arrDateiAlt = AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrDateiAlt = AlteDateien( arrDateiLst, Alter, ZeitType )
AlteDateien arrDateiLst, Alter, ZeitType
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "085 :: " & WScript.ScriptName
LogEintrag "087 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function AlteDateien( arrDateiLst, Alter, ZeitType )
'*********************************************************
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst, Ttt, i
Dim ZeitBezug : ZeitBezug = "NACH"
LogEintrag "126 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbCRLF
' 'ZeitBezug' auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Left( Alter, 1 ) = "-" Then ZeitBezug = "VOR" : Alter = Mid( Alter, 2 )
If Left( Alter, 1 ) = "+" Then ZeitBezug = "NACH" : Alter = Mid( Alter, 2 )
If ZeitType = "VOR" Then ZeitBezug = "VOR"
If ZeitType = "NACH" Then ZeitBezug = "NACH"
LogEintrag "135 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbCRLF
' Prüfen, ob der Inhalt von 'Alter' verwendbar ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not IsDate( Alter ) Then Alter = CLng( Alter )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
' Alter enthält weder ein Datum noch eine Zahl; Alter ist ungültig!
WSHShell.Popup "Falscher Parameter für ""Alter"": " & vbCRLF & vbTab & "'" & Alter & "' führt zu" & vbCRLF & vbTab & Tst, 30, "145 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
LogEintrag "148 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbCRLF
Tst = "-DATUM"
If InStr( Alter, ":" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "/" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "-" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "." ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If Tst <> "DATUM" Then Alter = CLng( Alter)
LogEintrag "155 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbTab & Tst & vbCRLF
' Dateinamen des Arrays testen und ggf. im Array löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
Tst = fso.GetFile( arrDateiLst( i ) ).DateLastModified
Ttt = DateDiff( ZeitType, Tst, now() )
If IsDate( Alter ) Then
' arrDateiLst( i ) = Clng( Tst - Alter ) & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Tst - Alter < 0 Then arrDateiLst( i ) = "" ' & "N " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Tst - Alter > 0 Then arrDateiLst( i ) = "" ' & "V " & arrDateiLst( i )
Else
' arrDateiLst( i ) = Ttt & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Ttt < Alter Then arrDateiLst( i ) = "" ' & "n " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Ttt > Alter Then arrDateiLst( i ) = "" ' & "v " & arrDateiLst( i )
End If
'DateDiff(Intervall, Datum1, Datum2 [,ErsterWochentag[,ErsteWocheimJahr]] )
'Die Syntax der DateDiff-Funktion besteht aus folgenden
Next
End Function ' AlteDateien( arrDateiLst, Alter, ZeitType )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "225 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "226 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "244 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "253 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienaltverschieben.vbs <<<
'*** v7.8 *** www.dieseyer.de ****************************
'
' Datei: dateienaltverschieben.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Verschiebt alle Dateien, die seit einem bestimmten Datum
' nicht mehr geändert wurden. Gibt es den ZielDateiNamen
' bereits, wird dieser mit einer dreistelligen Zahl fort-
' laufend hoch gezählt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile Tst, ZDatei
' fso.CopyFile Tst, ZDatei
'
'*********************************************************
Option Explicit
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim QuellPfad, ZielPfad, Alter
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
QuellPfad = "H:\\scr\backup"
QuellPfad = "\\dieseyer.pc.netz\d$\temp.zw"
QuellPfad = "SRV01.BEIMIR.LOKAL\d$\1test"
ZielPfad = "D:\temp.zw\zw"
Alter = 365 ' Dateien, die seit xxx Tagen nicht geändert wurden
LogEintrag vbCRLF
LogEintrag "027 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "028 :: LogDatei: " & LogDatei
' MsgBox AlteVerschieben (QuellPfad, ZielPfad, Alter ) ' Function Aufruf und Ergebnisanzeige
AlteVerschieben QuellPfad, ZielPfad, Alter ' Function Aufruf OHNE Ergebnisanzeige
LogEintrag "033 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
CreateObject("Wscript.Shell").Run LogDatei ' LogDatei anzeigen
WScript.Quit
'*********************************************************
Function AlteVerschieben (QPfad, ZPfad, Tage) ' Anfang
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
LogEintrag "044 :: Start der Function-Prozedur 'Function AlteVerschieben (QPfad, ZPfad, Tage)'"
LogEintrag "045 :: QPfad: " & QPfad
LogEintrag "046 :: ZPfad: " & ZPfad
LogEintrag "047 :: Dateien, die älter als " & Tage & " Tage sind (vor dem " & FormatDateTime( now() - Tage ,2) & " erstellt), sollen verschoben werden . . ."
Dim oFiles, n, i, Txt, Tst, ZDatei, File
If not InStrRev( ZPfad, "\" ) = Len( ZPfad ) Then ZPfad = ZPfad & "\" ' evtl. fehlendes \ am Ende entfernen
If not fso.FolderExists( QPfad ) Then
AlteVerschieben = "Das Quellverzeichnis " & UCase( QPfad ) & " existiert nicht!"
MsgBox AlteVerschieben, , "055 :: " & WScript.ScriptName
LogEintrag "056 :: " & AlteVerschieben
Exit Function
End If
If not fso.FolderExists( ZPfad ) Then
AlteVerschieben = "Das Zielverzeichnis " & UCase( ZPfad ) & " existiert nicht!"
MsgBox AlteVerschieben, , "062 :: " & WScript.ScriptName
LogEintrag "063 :: " & AlteVerschieben
Exit Function
End If
Set oFiles = fso.GetFolder( QPfad ).Files
For Each File In oFiles
Txt = File.DateLastModified
If DateDiff("d" , File.DateLastModified, FormatDateTime( now() - Tage ,2) ) > 0 Then ' Datei alt genug?
i = i + 1
n = 0 : Tst = ""
ZDatei = File
ZDatei = ZPfad & fso.GetBaseName( File) & Tst & "." & fso.GetExtensionName( File )
Do ' Schleife durchlaufen, bis ein 'freier' (Ziel-) Dateiname gefunden ist
If not fso.FileExists( ZDatei ) Then Exit Do
n = n + 1 : Tst = n
If Len( Tst ) < 3 Then Tst = "0" & Tst
If Len( Tst ) < 3 Then Tst = "0" & Tst
If Len( Tst ) < 3 Then Tst = "0" & Tst ' n mit führenden Nullen auffüllen
Tst = "-" & Tst
ZDatei = ZPfad & fso.GetBaseName( File) & Tst & "." & fso.GetExtensionName( File )
' MsgBox "File" & vbTab & "=>" & File & "<=" & vbCRLF & "ZDatei" & vbTab & "=>" & ZDatei & "<=", , "085 :: " & WScript.ScriptName
Loop
Tst = File
On Error Resume Next
' fso.MoveFile Tst, ZDatei
fso.CopyFile Tst, ZDatei
On Error GoTo 0
If not fso.FileExists( ZDatei ) Then
AlteVerschieben = AlteVerschieben & i & vbTab & Tst & vbTab & " nicht verschiebbar." & vbCRLF
LogEintrag "096 :: Datei vom " & Txt & " nicht verschiebbar: " & Tst
Else
AlteVerschieben = AlteVerschieben & i & vbTab & ZDatei & vbTab & " erstellt - Quelle gelöscht." & vbCRLF
LogEintrag "099 :: Datei vom " & Txt & " verschoben nach: " & ZDatei & " - QuellDatei: " & Tst
End if
Else
LogEintrag "103 :: --- Datei vom " & File.DateLastModified & " nicht alt genung zum verschieben: " & File
End If
Next
Set oFiles = nothing
Set fso = nothing
LogEintrag "110 :: " & i & " Dateien, die älter als " & Tage & " Tage sind (vor dem " & FormatDateTime( now() - Tage ,2) & " erstellt), wurden verschoben."
End Function ' AlteVerschieben (QPfad, ZPfad, Tage)
'*********************************************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienlisteholen.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienlisteholen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "035 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "036 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "038 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst, Tst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "046 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
Tst = Replace( WScript.ScriptFullName, WScript.Scriptname, "" )
' Tst enthält jetzt das aktuelle Verzeichnis
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "058 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "066 :: " & WScript.ScriptName
LogEintrag "068 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "119 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "120 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "138 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "147 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienvergleich-1.vbs <<<
'*** v10.2 *** www.dieseyer.de *****************************
'
' Datei: dateienvergleich-1.vbs
' Autor: W. Schmelz
' Auf: www.dieseyer.de
'
' Vergleich von zwei im Explorer markierter Dateien.
' Diese sind auch zusammen per Drag & Drop aufsetzbar.
' Die Unterschiede beider Dateien und Einschübe werden
' zeilenweise samt Nummerierung dieser Zeilen in einer
' Datei Datei-Vgl.txt im Programm-Ordner aufgelistet.
' Anfangs werden beide Dateien nummeriert angegeben.
' Die Leerstellen zum Einrücken (am Zeilenanfang) werden
' nicht beachtet. Die "Fc.exe" (FileCompare) von
' MS versagte an mehreren Beispielen und meldete Fehler -
' so hat sich die (Neu-) Programmierung immerhin gelohnt!
'
'***********************************************************
' CopyRight W. Schmelz, 10.02.2010 (Stammt aus 9/2007)
'Objekte u.a. für Arbeit des Programmes bereit stellen:
'******************************************************
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set IE=CreateObject("InternetExplorer.Application")
Set Arg=Wscript.Arguments
Titel=" Zwei Dateien vergleichen !"
UV=VbCR&VbCR
'Dim für Weitergabe zwischen Programm und Sub-Programmen:
'********************************************************
Dim Stelle, Neu1, Neu2, i, Plus1, Plus2, Ende1, Ende2, Ende
Dim Zeile1(), Zeile2(), Datei, Datei1, Datei2, Ident, Leer
Dim Nicht, Ort, Schrb, Edg1, Edg2, Dazu, Lang, Voll, Stern
Dim Verschd, Zeilen1(), Zeilen2()
'Prüfen, ob zwei Dateien zum Vergleich aufgesetzt wurden:
'********************************************************
If Arg.Count<>"2" then
Ask=MsgBox (UV&"Sollen jetzt zwei im Explorer zu bestimmen-"&_
UV&"de Dateien verglichen werden ? Die Dateien"&UV&_
"werden zeilenweise auf deren Unterschiede"&UV&_
"überprüft und während dessen getestet, ob "&_
UV&"in diese beiden Dateien Einschübe gemacht"&UV&_
"wurden ! Soll der Explorer geöffnet werden ?"&UV&_
"Man kann aber auch die 2 Dateien aufsetzen?"&UV, _
VbOkCancel+VbDefaultButton1+VbInformation+VbSystemModal,Titel)
If Ask="2" then WScript.Quit
else
'Evtl. aufgesetzte Dateien erkennen:
'***********************************
Datei1=Arg.Item(0)
Datei2=Arg.Item(1)
Text=" "&Arg.Item(0)&VbCR&" "&Arg.Item(1)
Ask=MsgBox(UV&"Folgende Dateien werden jetzt verglichen:"&_
" "&UV&Text&UV, _
VbOkCancel+VbDefaultButton1+VbInformation+VbSystemModal,Titel)
If Ask="2" then WScript.Quit
End If
'Falls nicht beide zu vergleichenden Dateien aufgesetzt wurden,
'statt dessen Auswahl der beiden Dateien im Explorer vornehmen:
'**************************************************************
If Arg.Count<>"2" then
IE.Navigate("About:Blank")
IE.Document.Write "<HTML><BODY><INPUT ID=""Files""Type=""File"">"
IE.Height="0" 'Muss sein, damit IE verborgen bleibt !!!
IE.Width="0"
IE.Visible=True
With IE.Document.All.Files
'Explorer-Fenster muss unbedingt sofort nach vorne kommen:
'*********************************************************
Befehl="about:blank - Microsoft Internet Explorer"
If Wss.AppActivate (Befehl) then Wss.AppActivate (Befehl)
'"Datei1" im Explorer auswählen:
'*******************************
.Click
Datei1= .Value
'Bei Abbruch der Auswahl:
'************************
If Datei1="" then
IE.Quit
Set IE=Nothing
WScript.Quit
End If
WScript.Sleep 500 '1/2 Sek. Pause zum Übergang
'"Datei2" im Explorer auswählen:
'*******************************
.Click
Datei2= .Value
IE.Quit
Set IE=Nothing
'Falls Dateien gleich oder Datei2="" sind:
'*****************************************
If Datei2="" then WScript.Quit
If Datei1=Datei2 then
MsgBox UV&" Abbruch, da die Datei1 = Datei2 !"&_
" "&UV,VbInformation+VbSystemModal,Titel
WScript.Quit
End If
End With
End If
'Prüfen, ob beide Dateien geeignet sind:
'***************************************
Edg1=LCase(Right(Datei1,3))
Edg2=LCase(Right(Datei2,3))
If not (Edg1="txt" or Edg1="vbs" or Edg1="hta" or _
Edg1="bat" or Edg1="sys" or Edg1="ini" or _
Edg1="log" or Edg1="cfg" or Edg1="old") or _
not (Edg2="txt" or Edg2="vbs" or Edg2="hta" or _
Edg2="bat" or Edg2="sys" or Edg2="ini" or _
Edg2="log" or Edg2="cfg" or Edg2="old") _
then MsgBox UV&"Diese Dateien sind leider ungeeignet! "&_
" "&UV,VbCritical+VbSystemModal,Titel:WScript.Quit
'Datei mit weniger Zeilen "Datei1" nennen:
'*****************************************
Set File1=Fso.OpenTextFile(Datei1,1,true)
i=1
Do until File1.AtEndOfStream
File1.ReadLine
i=i+1
Loop
Ende1=i-1
File1.Close
Set File1=Nothing
Set File2=Fso.OpenTextFile(Datei2,1,true)
i=1
Do until File2.AtEndOfStream
File2.ReadLine
i=i+1
Loop
Ende2=i-1
File2.Close
Set File2=Nothing
If Ende1>Ende2 then
DateiX=Datei1
Datei1=Datei2
Datei2=DateiX
else
'Nrn. bleiben so
End If
'"Datei1" zeilenweise auslesen:
'******************************
Set File1=Fso.OpenTextFile(Datei1,1,true)
i=1
Do until File1.AtEndOfStream
ReDim Preserve Zeile1(i)
Zeile1(i)=File1.ReadLine
i=i+1
Loop
Ende1=i-1
File1.Close
Set File1=Nothing
'"Datei2" zeilenweise auslesen:
'******************************
Set File2=Fso.OpenTextFile(Datei2,1,true)
i=1
Do until File2.AtEndOfStream
ReDim Preserve Zeile2(i)
Zeile2(i)=File2.ReadLine
i=i+1
Loop
Ende2=i-1
File2.Close
Set File2=Nothing
'Dateien gleich, wenn gleich lang und Zeilen identisch:
'******************************************************
If Ende1=Ende2 then
Ident="0" 'Sind sämtliche Zeilen gleich?
For i=1 to Ende1
If Zeile1(i)=Zeile2(i) then Ident=1+Ident
Next
If Ident=Ende1 then
MsgBox UV&"Datei1 = Datei2, sind völlig identisch !"&_
" "&UV,VbInformation,Titel : WScript.Quit
End If
End If
'"Ende" ist Länge der längeren "Datei2":
'***************************************
Ende=Ende2
'Zeilenunterschied der Dateien in Suche einplanen:
'*************************************************
'Folgende Spanne müsste beim Vergleich der Zeilen
'rückwärts und vorwärts ausreichend sein!?
Dazu=CInt(2*(Ende-Ende1))+50
'Leeren Zeilenüberhang für die Dateien schaffen:
'***********************************************
ReDim Preserve Zeile1(2*Ende)
For r=1+Ende1 to 2*Ende
Zeile1(r)=""
Next
ReDim Preserve Zeile2(2*Ende)
For r=1+Ende2 to 2*Ende
Zeile2(r)=""
Next
'Prüfen, ob die Dateien evtl. zu ungleich sind:
'**********************************************
Verschd="0"
x=1
Do until (x>200 or x>Ende1)
y=1
Do until (x>200 or y>Ende2)
If (Zeile1(x)=Zeile2(y) and Zeile1(x)<>"" and _
Left(Zeile1(x),1)<>"'" and LCase(Right(Zeile1(x),6)) _
<>"end if" and LCase(Right(Zeile1(x),4))<>"next" and _
LCase(Right(Zeile1(x),12))<>"wscript.quit" and _
LCase(Right(Zeile1(x),4))<>"else" and _
LCase(Right(Zeile1(x),7))<>"end sub" and _
LCase(Right(Zeile1(x),12))<>"end function" and _
LCase(Right(Zeile1(x),4))<>"loop") then Verschd=1+Verschd
y=y+1
Loop
x=x+1
Loop
'Abbruch, wenn viel zu wenige Gemeinsamkeiten bestehen:
'******************************************************
If (Verschd="0" or Verschd<=10) then MsgBox UV&VbTab&_
"Die Dateien sind viel zu "&_
"ungleich! "&UV,,Titel:WScript.Quit 'Abbruch!
'Zeit-Warnung, wenn beide Dateien sehr groß sind:
'************************************************
If Ende>1000 then MsgBox UV&VbTab&"Da die Dateien ziemlich "&_
"groß sind, "&UV&VbTab&"kann der Vergleich"&_
" etwas dauern!"&UV,VbSystemModal,Titel
'ZeilenX(r) nach Streichen der Leerstellen speichern:
'****************************************************
ReDim Preserve Zeilen1(Ende1)
For r=1 to Ende1
Zeilen1(r)=Zeile1(r)
Next
ReDim Preserve Zeilen2(Ende2)
For r=1 to Ende2
Zeilen2(r)=Zeile2(r)
Next
'In Zeilen1(i) Leerstellen u.ä. am Anfang streichen:
'***************************************************
For i=1 to Ende1
If Zeile1(i)<>"" then
Schluss="0"
k=1
Do until (k=Len(Zeile1(i))+1 or Schluss="1")
'Prüfen, ob anfangs Tabs/Leerstellen sind: streichen!
'****************************************************
If not (Mid(Zeile1(i),k,1)=" " or Mid(Zeile1(i),k,1)=" " _
or Mid(Zeile1(i),k,1)=" ") then
Schluss="1"
Zeile1(i)=Right(Zeile1(i),Len(Zeile1(i))-k+1)
End If
k=k+1
Loop
End If
Next
'In Zeilen2(i) Leerstellen u.ä. am Anfang streichen:
'***************************************************
For i=1 to Ende2
If Zeile2(i)<>"" then
Schluss="0"
k=1
Do until (k=Len(Zeile2(i))+1 or Schluss="1")
'Prüfen, ob anfangs Tabs/Leerstellen sind: streichen!
'****************************************************
If not (Mid(Zeile2(i),k,1)=" " or Mid(Zeile2(i),k,1)=" " _
or Mid(Zeile2(i),k,1)=" ") then
Schluss="1"
Zeile2(i)=Right(Zeile2(i),Len(Zeile2(i))-k+1)
End If
k=k+1
Loop
End If
Next
'############################################
'Datei für Angabe der Unterschiede festlegen und schreiben:
'**********************************************************
Datei=Left(Datei1,Len(Datei1)-4)&"-Vgl.txt"
Set File=Fso.OpenTextFile(Datei,2,true)
'Kopf der Unterschiede - Datei wird jetzt geschrieben,
'zunächst Dateien zeilenweise und nummeriert angeben !
'*****************************************************
File.WriteLine("")
File.WriteLine("")
File.WriteLine("Dies ist zeilenweise """&Datei1&"""")
File.WriteLine("**************************************************")
File.WriteLine("")
For a=1 to Ende1
File.WriteLine(a&VbTab&Zeilen1(a)) 'Bei VbTab Längenausgleich!
Next
File.WriteLine("")
File.WriteLine("")
File.WriteLine("################################################")
File.WriteLine("")
File.WriteLine("")
File.WriteLine("Dies ist zeilenweise """&Datei2&"""")
File.WriteLine("**************************************************")
File.WriteLine("")
For b=1 to Ende2
File.WriteLine(b&VbTab&Zeilen2(b))
Next
File.WriteLine("")
File.WriteLine("")
File.WriteLine("################################################")
File.WriteLine(" ################################################")
File.WriteLine("################################################")
File.WriteLine("")
File.WriteLine("")
File.WriteLine("Verglichen werden """&Datei1&"""")
File.WriteLine("und """&Datei2&"""")
File.WriteLine("")
File.WriteLine("Die Zahlen vorne sind Zeilen von Datei1 bzw. Datei2 ")
File.WriteLine("")
'Beide Dateien werden zeilenweise verglichen:
'********************************************
Plus1="0" 'Zusatzzeilen durch Einschübe in Datei1
Plus2="0" ' ... in Datei2
For i=1 to Ende '<<<<<< Suchschleife
If (i+Plus1>Ende1 or i+Plus2>Ende2) then Fertig 'beenden!
'Prüfen, wie weit ab dem Ort die Dateizeilen gleich sind:
'********************************************************
Ort=i
GleicheZeilen 'Sub-Programm aufrufen, s.u.
i=Stelle 'Neuen Startpunkt festlegen!
'Ab hier wieder ungleich!
Leerzeilen 'Evtl. Leerzeilen danach werden übersprungen:
'Besteht Änderung einer einzelnen Zeile in beiden Dateien?
'Einschübe in eine Datei oder Einschübe neben Änderungen??
'*********************************************************
Erfolg="0"
Aenderg 'Änderung, Einschübe, Änderung + Einschübe testen!
Stelle=1+i 'Evtl. Leerzeilen danach werden übersprungen!
Leerzeilen
Next '<<<<<<<< Ende der Suchschleife
'Sub-Programm zum Schließen dieses Programmes:
'*********************************************
Fertig
WScript.Quit
'############################################
'**************************************************
' *
' Als Nächstes die erforderlichen Sub - Programme *
' *
'**************************************************
Sub Leerzeilen
'Evtl. Leerzeilen danach überspringen:
'*************************************
If (Zeile1(Stelle+Plus1)="" or Zeile2(Stelle+Plus2)="") then
'Überprüfung von "Datei1" auf Leerzeilen:
'****************************************
Leer="0"
Plus="0"
k=0
Do until (Leer="1" or Stelle+Plus1+k>Ende1)
If Zeile1(Stelle+Plus1+k)="" then
Plus=1+Plus
else
Leer="1"
End If
k=k+1
Loop
If (Leer="1" and Plus<>"0") then Plus1=Plus1+Plus
'Überprüfung von "Datei2" auf Leerzeilen:
'****************************************
Leer="0"
Plus="0"
k=0
Do until (Leer="1" or Stelle+Plus2+k>Ende2)
If Zeile2(Stelle+Plus2+k)="" then
Plus=1+Plus
else
Leer="1"
End If
k=k+1
Loop
If (Leer="1" and Plus<>"0") then Plus2=Plus2+Plus
End If
End Sub
'############################################
Sub Fertig
'Unterschiede-Datei, Programm schließen, Ergebnis ausgeben:
'**********************************************************
File.Close
Set File=Nothing
'Datei mit Liste der Unterschiede öffnen, ggf. löschen(?):
'*********************************************************
Wss.Run "Notepad """&Datei&""" "
WScript.Sleep 500
'Frage, ob die ausgegebene Datei zu löschen ist:
'***********************************************
Ask=MsgBox(UV&UV&"Soll die Datei mit den Unterschieden "&_
"gelöscht werden ? "&UV&"Sie befindet"&_
" sich im Verzeichnis der ersten Datei!"&_
UV&UV,VbYesNo+VbDefaultButton2+VbCritical,Titel)
If Ask="7" then WScript.Quit 'Bei "Nein" Abbruch!
'Auf Wunsch Datei mit den Unterschieden löschen:
'***********************************************
Fso.DeleteFile Datei
WScript.Quit
End Sub
'############################################
Sub GleicheZeilen
'Prüfen, bis wohin "Datei1" und "Datei2" gleich sind:
'****************************************************
Schluss="0"
x=Ort
Do until (Schluss="1" or x+Plus1>Ende1 or x+Plus2>Ende2)
If Zeile1(x+Plus1)<>Zeile2(x+Plus2) then
Schluss="1"
Stelle=x 'Bei x-1 letztes Mal gleiche Zeilen!
If x>Ort then Exit Sub 'Falls gleiche Zeilen da!
End If
x=x+1
Loop
Stelle=Ort 'Wenn keine neuen gleichen Zeilen gefunden
End Sub
'############################################
Sub Aenderg 'Enthält ein Unter-Sub-Programm
'Prüfen, ob einzelne Zeile verändert wurde:
'******************************************
Erfolg="0"
If (Zeile1(i+Plus1)<>Zeile2(i+Plus2) and _
Zeile1(i+Plus1+1)=Zeile2(i+Plus2+1) and _
Zeile1(i+Plus1+1)<>"") then
File.WriteLine("")
File.WriteLine("####### Diese Einzelzeile wurde geändert: #######")
File.WriteLine((i+Plus1)&VbTab&Zeilen1(i+Plus1))
File.WriteLine((i+Plus2)&VbTab&Zeilen2(i+Plus2))
File.WriteLine("#################################################")
File.WriteLine("")
Plus1=1+Plus1
Plus2=1+Plus2
Erfolg="1"
Exit Sub 'Zurück !
End If
'******************************************************
'* *
'* Falls hier keine veränderte Einzelzeile vorliegt : * *
'* Testen, ob Einschübe zu finden sind oder geänderte *
'* Zeilen samt Einschüben zusammen vorliegen können : *
'* *
'******************************************************
WeiterSuchen 'Obiges in weiterem Sub-Programm testen
If Erfolg="1" then Exit Sub
End Sub
'############################################
Sub WeiterSuchen
If Zeile1(i+Plus1)<>Zeile2(i+Plus2) then
'Evtl. Einschub1 in "Datei1" ermitteln:
'**************************************
Neu1="0"
Gleich="0"
a=1
Do until (Gleich="1" or i+Plus1+a>Ende1 or a>Dazu)
If (Zeile1(i+Plus1+a)=Zeile2(i+Plus2) and _
Zeile2(i+Plus2)<>"") then Gleich="1"
a=a+1
Loop
If (a-1>0 and Gleich="1") then Neu1=a-1
'Evtl. Einschub2 in "Datei2" ermitteln:
'**************************************
Neu2="0"
Gleich="0"
If Zeile1(i+Plus1)<>Zeile2(i+Plus2) then
b=1
Do until (Gleich="1" or i+Plus2+a>Ende2 or b>Dazu)
If (Zeile1(i+Plus1)=Zeile2(i+Plus2+b) and _
Zeile1(i+Plus1)<>"") then Gleich="1"
b=b+1
Loop
If (b-1>0 and Gleich="1") then Neu2=b-1
End If
'Wenn welche gefunden, den sinnvolleren Einschub wählen:
'*******************************************************
If (Neu1>0 or Neu2>0) then
If ((Neu1>0 and Neu2=0) or Neu1<Neu2) then
Einschub1
Erfolg="1"
Exit Sub
End If
If ((Neu1=0 and Neu2>0) or Neu2<=Neu1) then
Einschub2
Erfolg="1"
Exit Sub
End If
End If
'Ein Einschub neben geänderten Zeilen in den Dateien,
'oder unterschiedliche Zeilenblöcke in den Dateien !?
'****************************************************
Gleich="0"
Grenz="0"
k=i+Plus1
Do until (k>i+Plus1+Dazu or k>Ende1 or Gleich="1")
'Beim Vergleich der Zeilen rückwärts und vorwärts schauen:
'*********************************************************
l=k-Dazu 'aber nicht vor letzte Gleichheit gehen:
If k-Dazu<i+Plus2 then l=i+Plus2
Do until (l>i+Plus2+Dazu or l>Ende2 or Gleich="1")
'Verhindern, dass '********* o.ä. zur Gleichheit führt:
'******************************************************
Stern="0"
Lang=Len(Zeile1(k))
'Zeile mit gleichen Zeichen muss mind. 4 Stellen haben:
'******************************************************
If Lang>=4 then
If (Mid(Zeile1(k),Lang-2,1)=Mid(Zeile1(k),Lang-1,1) and _
Mid(Zeile1(k),Lang-1,1)=Right(Zeile1(k),1)) then Stern="1"
End If
'Prüfen, ob Zeilen gleich sind:
'******************************
If (Zeile1(k)=Zeile2(l) and (Right(Zeile1(k),4) _
<>"("""")" and Zeile1(k)<>"" and Stern="0" and _
k>i+Plus1 and l>i+Plus2)) then
Gleich="1"
Erfolg="1"
End If
l=l+1
Loop
k=k+1
Loop
'Falls in den Dateien nur Leerzeilen zu finden:
'**********************************************
Nicht="0"
For a=i+Plus1-1 to k-1
If Zeile1(a)<>"" then Nicht="1"
Next
For b=i+Plus2-1 to l-1
If Zeile2(b)<>"" then Nicht="1"
Next
If Nicht="0" then
Plus1=Plus1+k-1-(i+Plus1) 'Verschiebungen notieren!
Plus2=Plus2+l-1-(i+Plus2)
Exit Sub
End If
'Falls nichts Gleiches mehr zu finden:
'*************************************
If k>Ende1 then
Grenz="1"
Gleich="1"
End If
'Wenn, dann bis zum Ende ungleiche Zeilen ausgeben:
'**************************************************
If Grenz="1" then
k=Ende1+2
l=Ende2+2
End If
'Unterschiede von "Datei1" und "Datei2" notieren:
'*************************************************
If Gleich="1" then
File.WriteLine("")
File.WriteLine("§§§§§§§ Die Unterschiede in Datei1 §§§§§§§")
If k-1=Ende1 then k=k-1 'Am Ende von "Datei1" um 1 zurücknehmen
For a=i+Plus1-1 to k-2 'bei k-2 schon gleiche Zeile gefunden !
File.WriteLine((a)&VbTab&Zeilen1(a))
Next
File.WriteLine("§§§§§§§ und Datei2 §§§§§§§")
If l-1=Ende2 then l=l-1 'Am Ende von "Datei2" um 1 zurücknehmen
For b=i+Plus2-1 to l-2 'bei l-2 schon gleiche Zeile gefunden !
File.WriteLine((b)&VbTab&Zeilen2(b))
Next
File.WriteLine("§§§§§§§ Dies waren die Unterschiede §§§§§§§")
File.WriteLine("")
Plus1=Plus1+k-1-(i+Plus1) 'Verschiebungen berücksichtigen!
Plus2=Plus2+l-1-(i+Plus2)
End If
End If
End Sub
'############################################
Sub Einschub1
'Erkannten Einschub1 aus "Datei1" schreiben:
'*******************************************
'Prüfen, ob nicht alles nur Leerzeilen waren:
'********************************************
Voll="0"
For z=1 to Neu1
If Zeile1(i+Plus1+z-1)<>"" then Voll="1"
Next
If Voll="0" then
Plus1=Plus1+Neu1 'Verschiebung durch Einschub2
Exit Sub 'bei Leerzeilen einen Abbruch
End If
File.WriteLine("")
File.WriteLine("Dies ist ein Einschub in die Datei1 : ")
File.WriteLine(">> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >> ")
For z=1 to Neu1
File.WriteLine((i+Plus1+z-1)&VbTab&Zeilen1(i+Plus1+z-1))
Next
File.WriteLine(">> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >>")
File.WriteLine("")
Erfolg="1"
'Verschiebung durch den Einschub1 festhalten:
'********************************************
Plus1=Plus1+Neu1
End Sub
'############################################
Sub Einschub2
'Erkannten Einschub2 aus "Datei2" schreiben:
'*******************************************
'Prüfen, ob nicht alles nur Leerzeilen waren:
'********************************************
Voll="0"
For z=1 to Neu2
If Zeile2(i+Plus2+z-1)<>"" then Voll="1"
Next
If Voll="0" then
Plus2=Plus2+Neu2 'Verschiebung durch Einschub2
Exit Sub 'bei Leerzeilen einen Abbruch
End If
File.WriteLine("")
File.WriteLine("Dies ist ein Einschub in die Datei2 : ")
File.WriteLine(">> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >> ")
For z=1 to Neu2
File.WriteLine((i+Plus2+z-1)&VbTab&Zeilen2(i+Plus2+z-1))
Next
File.WriteLine(">> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >>")
File.WriteLine("")
Erfolg="1"
'Verschiebung durch den Einschub2 festhalten:
'********************************************
Plus2=Plus2+Neu2
End Sub
#########################################################################
>>> dateienvergleich.vbs <<<
'*** v7.8 *** www.dieseyer.de *******************************
'
' Datei: dateienvergleich.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Vergleich zwei Dateien mit "fc /b %1 %2"
'
' Vergleicht, wie der Name bereits verrät, (zwei) Dateien -
' über eine Auswahl per Binär- oder Textvergleich. Dazu die
' beiden zu vergleichenden Dateien auf das Skript ziehen und
' fallen lassen (Drag & Drop). Wird das Skript (mit Doppel-
' klick) gestartet, bietet es an, das Windows-Explorer -
' Kontextmenü zu erweitern. Dann kann man im Explorer zwei
' Dateien markieren und (dann durch Klicken mit der rechten
' Maus-Taste und über 'Senden an') die markierten Dateien an
' das Skript übergeben.
' Das Skript verwendet das Befehlszeilenprogramm 'fc.exe',
' das beim zeilenweisen Vergleich auch nach mehren (unter-
' schiedlichen) Zeilen wieder synchronisiert - DAS wollte
' ich nicht nach programmieren.
'
'************************************************************
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"""
' 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 Maus 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 )
'***************************************************************
#########################################################################
>>> dateienverschieben-alteloeschen.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben-alteloeschen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Erstellt für www.roton.de
'
' Ursprungsskript:
' dateienalteliste.vbs
' mit der Prozedur AlteDateien( arrDateiLst, Alter, ZeitType )
'
' Erweiterung(en):
' - DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' aus dateienverschieben_zufall.vbs
' - DateiListeLoeschen( arrDateiLst )
' aus dateienaltdelete-3.vbs
' - Parameter für das ZielVerz.
' - Parameter um das Löschen zu aktivieren/deaktivieren (LoeschenAktiv = "YES")
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
' Für die Prozedur AlteDateien( arrDateiLst, Alter, ZeitType )
Const QuellVerz = "C:\dieseyer.de\scr"
Const Alter = 26
Const ZeitType = "d"
' Für die Prozedur DateienVerschiebenZufall( arrDateiLst, ZielVerz )
Const ZielVerz = "c:\temp.zw\zw"
' Für die Prozedur DateiListeLoeschen( arrDateiLst )
Const LoeschenAktiv = "YES"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "050 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "051 :: LogDatei: " & LogDatei
LogEintrag "052 :: ZielVerz: """ & ZielVerz & "\"" "
LogEintrag "053 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "055 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'' arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "064 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
' ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenZufall arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( ZielVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "078 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
AlteDateien arrDateiLst, Alter, ZeitType
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateiListeLoeschen arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "096 :: " & WScript.ScriptName
LogEintrag "098 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateiListeLoeschen( arrDateiLst )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim i, m, n, z, Tst
i = 0 : m = 0 : n = 0 : z = 0
LogEintrag "110 :: Start der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
If LoeschenAktiv = "YES" Then LogEintrag "112 :: LÖSCHEN IST AKTIV - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
If LoeschenAktiv <> "YES" Then LogEintrag "113 :: LÖSCHEN IST DEAKTIVIERT - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
' Dateinamen des Arrays testen und Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
On Error Resume Next
Tst = " - "
If LoeschenAktiv = "YES" Then fso.DeleteFile arrDateiLst( i )
If LoeschenAktiv <> "YES" Then LogEintrag "123 :: Datei( " & i & " ) wird NICHT gelöscht: " & arrDateiLst( i )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
LogEintrag "129 :: Datei( " & i & " ) nicht löschbar: " & arrDateiLst( i ) & " " & Tst
z = z + 1
Else
If LoeschenAktiv = "YES" Then n = n + 1 : LogEintrag "132 :: Datei( " & i + 1 & " ) gelöscht: " & arrDateiLst( i )
End If
Else
If Len( arrDateiLst( i ) ) > 3 Then
LogEintrag "136 :: Datei( " & i & " ) fehlt (kann daher nicht gelöscht werden): " & arrDateiLst( i )
Else
m = m + 1
' LogEintrag "139 :: Datei( " & i & " ): " & arrDateiLst( i )
End If
End If
Next
LogEintrag "144 :: " & n & " von " & i & " Dateien gelöscht."
LogEintrag "145 :: " & z & "x ist ein Fehler beim Löschen einer Datei aufgetreten."
LogEintrag "146 :: " & m & " Arrayeinträge waren leer bzw. enthielten keinen gültigen Dateinamen."
LogEintrag "147 :: Ende der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
End Function ' DateiListeLoeschen( arrDateiLst )
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine zufällige
' 5stellige Hex-Zahl eingefügt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "181 :: Start der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
LogEintrag "182 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "183 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "192 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "200 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "203 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
' Ergänzung ermitteln; 5stellige Hex-Zahl
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
Tst = UCase( fso.GetTempName ) ' ergibt z.B.: rad01443.tmp
Tst = Replace( Tst, ".TMP", "" ) ' ".tmp" entfernen
Tst = Mid( Tst, 4 ) ' ab der 4. Stelle, also nach "rad"
Tst = ZielVerz & "\" & ZielName & "_" & Tst & "." & ZielErw
If not fso.FileExists( Tst ) Then ZwName = Tst : Exit Do
Loop
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "239 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "240 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "242 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "246 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "248 :: Ende der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function AlteDateien( arrDateiLst, Alter, ZeitType )
'*********************************************************
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst, Ttt, i
Dim ZeitBezug : ZeitBezug = "NACH"
LogEintrag "286 :: Start der Prozedur 'AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )'"
' LogEintrag "287 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' 'ZeitBezug' auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Left( Alter, 1 ) = "-" Then ZeitBezug = "VOR" : Alter = Mid( Alter, 2 )
If Left( Alter, 1 ) = "+" Then ZeitBezug = "NACH" : Alter = Mid( Alter, 2 )
If ZeitType = "VOR" Then ZeitBezug = "VOR"
If ZeitType = "NACH" Then ZeitBezug = "NACH"
' LogEintrag "296 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' Prüfen, ob der Inhalt von 'Alter' verwendbar ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not IsDate( Alter ) Then Alter = CLng( Alter )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
' Alter enthält weder ein Datum noch eine Zahl; Alter ist ungültig!
WSHShell.Popup "Falscher Parameter für ""Alter"": " & vbCRLF & vbTab & "'" & Alter & "' führt zu" & vbCRLF & vbTab & Tst, 30, "306 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' LogEintrag "309 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
Tst = "-DATUM"
If InStr( Alter, ":" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "/" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "-" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "." ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If Tst <> "DATUM" Then Alter = CLng( Alter)
LogEintrag "316 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & " - " & Tst
' Dateinamen des Arrays testen und ggf. im Array löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
Tst = fso.GetFile( arrDateiLst( i ) ).DateLastModified
Ttt = DateDiff( ZeitType, Tst, now() )
If IsDate( Alter ) Then
' arrDateiLst( i ) = Clng( Tst - Alter ) & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Tst - Alter < 0 Then arrDateiLst( i ) = "" ' & "N " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Tst - Alter > 0 Then arrDateiLst( i ) = "" ' & "V " & arrDateiLst( i )
Else
' arrDateiLst( i ) = Ttt & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Ttt < Alter Then arrDateiLst( i ) = "" ' & "n " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Ttt > Alter Then arrDateiLst( i ) = "" ' & "v " & arrDateiLst( i )
End If
'DateDiff(Intervall, Datum1, Datum2 [,ErsterWochentag[,ErsteWocheimJahr]] )
'Die Syntax der DateDiff-Funktion besteht aus folgenden
Next
LogEintrag "337 :: Start der Prozedur 'AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )'"
End Function ' AlteDateien( arrDateiLst, Alter, ZeitType )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "388 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "389 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "407 :: Start der Prozedur 'Dateilisteholen( " & Verz & " )'"
LogEintrag "408 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "417 :: i = " & i & vbTab & DateilisteholenX(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
LogEintrag "425 :: Ende der Prozedur 'Dateilisteholen( " & Verz & " )'"
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienverschieben_lfd.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben_lfd.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' DateienVerschiebenLFD() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenLFD( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; nach der letzten, die vorhandenen
' ist: Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt
' (von t.txt) vorhanden, wird t_009.txt, nicht
' t_003.txt, erstellt.
'
' Existiert t_999.txt, gibt es eine Fehlermeldung und
' die Datei t_999.txt wird überschrieben!
'
' Da für jede Datei geprüft wird, ob es welche mit
' den Zahlen zw. 000 undd 999 gibt, ist das Skript
' sehr langsam.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const ZielVerz = "D:\temp.zw\zw"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "059 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
'LogEintrag "070 :: arrDateiAlt = DateienAlte( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenLFD arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "082 :: " & WScript.ScriptName
LogEintrag "084 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenLFD() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenLFD( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; nach der letzten, die vorhandenen
' ist: Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt
' (von t.txt) vorhanden, wird t_009.txt, nicht
' t_003.txt, erstellt.
'
' Existiert t_999.txt, gibt es eine Fehlermeldung und
' die Datei t_999.txt wird überschrieben!
'
' Da für jede Datei geprüft wird, ob es welche mit
' den Zahlen zw. 000 undd 999 gibt, ist das Skript
' sehr langsam.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "129 :: Start der Function-Prozedur 'Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )'"
LogEintrag "130 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "131 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "140 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "148 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "151 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
Tst = ZielVerz & "\" & ZielName & "." & ZielErw
z = 0
' 3stellige Zahl ermitteln
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ttt = "-OK"
Do
If not fso.FileExists( Tst ) AND Ttt = "-OK" Then ZwName = Tst : Ttt = "OK"
If fso.FileExists( Tst ) Then Ttt = "-OK" ' : MsgBox Tst, , "181 :: "
z = z + 1 : Txt = z : If Len( Txt ) < 3 Then Txt = "0" & Txt : If Len( Txt ) < 3 Then Txt = "0" & Txt
Tst = ZielVerz & "\" & ZielName & "_" & Txt & "." & ZielErw
If Txt = "999" AND Ttt = "-OK" Then ZwName = Tst : Exit Do
If Txt = "999" Then Exit Do
Loop
If fso.FileExists( ZwName ) Then LogEintrag "188 :: Vorhandene Datei wird überschrieben: """ & ZwName & """ "
If fso.FileExists( ZwName ) Then WSHShell.Popup "Vorhandene Datei wird überschrieben: """ & ZwName & """ ", 3, "189 :: " & WScript.ScriptName
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "194 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "195 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "197 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "201 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "203 :: Ende der Function-Prozedur 'Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenLFD( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "254 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "255 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "273 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "282 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienverschieben_nr.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben_nr.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' DateienVerschiebenNR() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenNR( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; die erste, die möglich ist:
' Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt (von
' t.txt) vorhanden, wird t_003.txt, nicht t_009.txt,
' erstellt.
'
' Sind alle Dateien bis t_999.txt, gibt es eine Fehler-
' meldung und die Datei t_999.txt wird überschrieben!
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const ZielVerz = "D:\temp.zw\zw"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "055 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
'LogEintrag "066 :: arrDateiAlt = DateienAlte( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenNR arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "078 :: " & WScript.ScriptName
LogEintrag "080 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenNR( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenNR() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenNR( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; die erste, die möglich ist:
' Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt (von
' t.txt) vorhanden, wird t_003.txt, nicht t_009.txt,
' erstellt.
'
' Sind alle Dateien bis t_999.txt, gibt es eine Fehler-
' meldung und die Datei t_999.txt wird überschrieben!
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "121 :: Start der Function-Prozedur 'Function DateienVerschiebenNR( arrDateiLst, ZielVerz )'"
LogEintrag "122 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "123 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "132 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "140 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "143 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
Tst = ZielVerz & "\" & ZielName & "." & ZielErw
z = 0
' 3stellige Zahl ermitteln
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
If not fso.FileExists( Tst ) Then ZwName = Tst : Exit Do
z = z + 1 : Txt = z : If Len( Txt ) < 3 Then Txt = "0" & Txt : If Len( Txt ) < 3 Then Txt = "0" & Txt
Tst = ZielVerz & "\" & ZielName & "_" & Txt & "." & ZielErw
Loop
If fso.FileExists( ZwName ) Then LogEintrag "176 :: Vorhandene Datei wird überschrieben: """ & ZwName & """ "
If fso.FileExists( ZwName ) Then WSHShell.Popup "Vorhandene Datei wird überschrieben: """ & ZwName & """ ", 3, "177 :: " & WScript.ScriptName
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "182 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "183 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "185 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "189 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "191 :: Ende der Function-Prozedur 'Function DateienVerschiebenNR( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenNR( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "242 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "243 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "261 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "270 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienverschieben_zufall.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben_zufall.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine zufällige
' 5stellige Hex-Zahl eingefügt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const ZielVerz = "D:\temp.zw\zw"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "049 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
'LogEintrag "060 :: arrDateiAlt = DateienAlte( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenZufall arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "072 :: " & WScript.ScriptName
LogEintrag "074 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine zufällige
' 5stellige Hex-Zahl eingefügt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "109 :: Start der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
LogEintrag "110 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "111 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "120 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "128 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "131 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
' Ergänzung ermitteln; 5stellige Hex-Zahl
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
Tst = UCase( fso.GetTempName ) ' ergibt z.B.: rad01443.tmp
Tst = Replace( Tst, ".TMP", "" ) ' ".tmp" entfernen
Tst = Mid( Tst, 4 ) ' ab der 4. Stelle, also nach "rad"
Tst = ZielVerz & "\" & ZielName & "_" & Tst & "." & ZielErw
If not fso.FileExists( Tst ) Then ZwName = Tst : Exit Do
Loop
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "167 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "168 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "170 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "174 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "176 :: Ende der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "227 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "228 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "246 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "255 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> 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
#########################################################################
>>> dateierstellt.vbs <<<
Option Explicit
Dim Tst
Tst = "c:\1test"
Tst = "D:\temp.zw\"
Tst = "D:\temp.zw"
Tst = FileCreationEvent( ".", Tst )
MsgBox "=>" & Tst & "<=", , "0005 :: "
'**************************************************************
Function FileCreationEvent( PC, FolderOnPC)
'**************************************************************
Dim Txt
FolderOnPC = Replace( FolderOnPC, "\", "\\\\" )
' MsgBox "FolderOnPC: " & FolderOnPC, , "0012 :: "
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colMonitoredEvents : Set colMonitoredEvents = objWMIService.ExecNotificationQuery ("SELECT * FROM __InstanceCreationEvent WITHIN 10 WHERE Targetinstance ISA 'CIM_DirectoryContainsFile' and TargetInstance.GroupComponent= 'Win32_Directory.Name=""" & FolderOnPC & """'")
Txt = ""
Dim objLatestEvent
Do
Set objLatestEvent = colMonitoredEvents.NextEvent
Txt = Txt & vbCRLF & Now() & vbTab & objLatestEvent.TargetInstance.PartComponent
MsgBox Txt, 4096, "0020 :: "
Loop
End Function ' FileCreationEvent( PC, FolderOnPC)
#########################################################################
>>> dateierweiterung-1zeichen.vbs <<<
'v5.1*****************************************************
' 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) to UBound(Datei)
if Fso FileExists( Datei(i) ) Then
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
End If
Next
' Was angerichtet wurde wird angezeigt:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox "In " & UCase(Pfad) & " wurden folgende Dateien umbenannt:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
Text = ""
WScript.Quit
#########################################################################
>>> dateiliste-nach-datum.vbs <<<
'v5.9********************************************************
' File: dateiliste-nach-datum.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt die Dateien eines Ordners nach Änderungsdatum sortiert an.
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Pfad, Ttt, Txt, Tst, i
Dim oFolders, oFiles, DateiX
Pfad = "c:\"
' Dateiliste => http://dieseyer.de/scr-html/datei-verzeichnis-liste.html:
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
Ttt = DateiX.DateLastModified
' Ttt = "22.6.2005 17:22:11"
' Ttt = "2005-06-22 17:22:12"
Tst = DateDiff( "s", CDate( Ttt ), Now() )
Txt = String( 11 - Len( Tst ), "0" ) & Tst
' MsgBox Ttt & vbCRLF & CDate( Ttt ) & vbCRLF & Tst & vbCRLF & Txt
ReDim Preserve Datei(i)
Datei(i) = Txt & DateiX.Name & " " & vbTab & "letzte Änderung: " & Ttt
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' sortieren => http://dieseyer.de/dse-wsh-scr-d.html#sortbub
QuickSort Datei, LBound(Datei), UBound(Datei)
Txt = ""
' korregieren:
For i = LBound( Datei ) to UBound( Datei )
Datei(i) = Mid ( Datei(i), 12 )
Txt = Txt & Datei(i) & vbCRLF
Next
MsgBox Txt, , WScript.ScriptName
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 ' QuickSort(vntArray, intVon, intBis)
#########################################################################
>>> dateiliste-nach-datum2.vbs <<<
'v5.9********************************************************
' File: dateiliste-nach-datum2.vbs
' Autor: "TheDude"
' dieseyer.de
'
' Zeigt die Dateien eines Ordners nach Änderungsdatum sortiert an.
'************************************************************
' "TheDude" : http://source-center.de/forum/showthread.php?postid=30837#post30837
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim pf : Set pf = fso.GetFolder("c:\").SubFolders
Dim datalist : Set datalist = CreateObject("ADOR.Recordset")
Dim f, Txt
datalist.Fields.Append "p",200,255
datalist.Fields.Append "lm",200,255
datalist.Open
For Each f In pf
datalist.AddNew Array("p","lm"), Array(f.path,DateDiff("s","01/01/1970 00:00:00",f.DateLastModified))
Next
datalist.Sort = "lm DESC"
Do While Not datalist.EOF
' Txt = Txt & datalist("p") & vbTab & datalist("lm") & vbCRLF
Txt = Txt & datalist("lm") & vbTab & datalist("p") & vbCRLF
datalist.MoveNext
Loop
MsgBox Txt, , WScript.ScriptName
#########################################################################
>>> dateilisteholenmitdatumundname.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: dateilisteholenmitdatumundname.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit
Dim Tst
Tst = DateilisteHolenMitDatumUndName( "c:\windows\", "KB956" )
Call ArrayZeigen( Tst )
Call ArrayZeigen( DateilisteHolenMitDatumUndName( "c:\windows\", "" ) )
Wscript.Quit
'*** v9.3 *** www.dieseyer.de ******************************
Function DateilisteHolenMitDatumUndName( Verz, DNA )
'***********************************************************
' Die Prozedur
' DateilisteHolenMitDatumUndName( Verz, DNA )
' gibt ein Array mit dem Dateinamen (ohne Verzeichnis) von
' allen Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind - vor dem Dateinamen steht das Änderungsdatum
' (Datum & Uhrzeit; ähnlich DMTF). Ein rekursives Auflisten
' der Datein in Unterverzeichnissen erfolgt nicht!
' DNA: DateiNamenAnfang; z.B. alle Dateien, die mit "KB" beginnen
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Dim i, oFolder, oFiles, DateiX, ZeitPkt, Tst, Txt, errTst
ReDim Preserve DateilisteholenX( 0 )
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
If InStr( UCase( DateiX.Name ), UCase( DNA ) ) = 1 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX( i )
On Error Resume Next
' Tst = fso.GetFile( DateiX & ".dd" ).DateLastModified
Tst = fso.GetFile( DateiX ).DateLastModified
errTst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( errTst ) > 5 Then
DateilisteholenX( i ) = "Fehler: PC nicht (mehr) erreichbar um " & now()
DateilisteHolenMitDatumUndName = DateilisteholenX
Exit Function
End If
ZeitPkt = Year( Tst )
Txt = Month( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Day( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Hour( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Minute( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Second( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
DateilisteholenX( i ) = ZeitPkt & "~" & DateiX.Name
i = i + 1
End If
End If
Next
Set oFiles = nothing
Set oFolder = nothing
DateilisteHolenMitDatumUndName = DateilisteholenX
End Function ' DateilisteHolenMitDatumUndName( Verz, DNA )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "131 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> dateilisteholennachname.vbs <<<
'*** v9.1 *** www.dieseyer.de ******************************
'
' Datei: dateilisteholennachname.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit
Dim Tst
Tst = DateilisteHolenNachName( "c:\windows\", "KB956", "log" )
Call ArrayZeigen( Tst )
Wscript.Quit
'*** v9.1 *** www.dieseyer.de ******************************
Function DateilisteHolenNachName( Verz, DNA, DNX )
'***********************************************************
' Die Prozedur
' DateilisteHolenNachName( Verz, DNA, DNX )
' gibt ein Array mit dem Dateinamen (mit Verzeichnis) von
' allen Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind.
' DNA: DateiNamenAnfang
' DNX: DateiNamenErweiterung (Extension)
' Ein rekursives Auflisten der Datein in Unterver-
' zeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Dim i, oFolder, oFiles, DateiX, ZeitPkt, Tst, Txt, errTst
ReDim Preserve DateilisteholenX( 0 )
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Tst = LCase( fso.GetExtensionName( DateiX ) ) ' : MsgBox Tst, , "047 :: " : WScript.Quit
If Tst = DNX and InStr( UCase( DateiX.Name ), UCase( DNA ) ) = 1 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX( i )
DateilisteholenX( i ) = DateiX
i = i + 1
End If
End If
Next
Set oFiles = nothing
Set oFolder = nothing
DateilisteHolenNachName = DateilisteholenX
End Function ' DateilisteHolenNachName( Verz, DNA, DNX )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "107 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> dateinachwortdurchsuchen.vbs <<<
'v7.8*****************************************************
' File: dateinachwortdurchsuchen.vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Beliebige Datei auf dieses Programm ziehen und loslassen!
' Ein zu suchendes Wort eingeben, groß und klein wichtig !!
' Die Zeilen mit dem gesuchten Wort werden dann mit der Num-
' merierung angezeigt!
'*********************************************************
'CopyRight W. Schmelz, 09.08.2007
'Objekte für das Programm bereit stellen:
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Arg=Wscript.Arguments
Titel=" Wort in Datei suchen !"
'Aufgesetzte Datei ermitteln:
For i=0 to Arg.Count -1
Datei=Arg.Item(i)
Next
'Falls keine Datei aufgesetzt wurde:
UV=VbCR&VbCR
If Datei="" then MsgBox UV&VbCR&_
" Bitte eine Datei aufsetzen,"&UV&_
" in der Wort gesucht werden soll ! "&_
UV&VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Abfrage des zu suchenden Wortes oder Abbruch:
Wort=InputBox(UV&UV&_
" Geben Sie das zu suchende Wort ein !"&UV&_
" Achten Sie auf kleine / große Buchstaben !"&UV&UV,Titel)
If Wort="" then WScript.Quit
'Aufgesetzte Datei öffnen und lesen:
Set File=Fso.OpenTextFile(Datei,1,true)
i=1
Do until File.AtEndOfStream
ReDim Preserve Zeile(i)
Zeile(i)=File.ReadLine
i=i+1
Loop
Ende=i-1
File.Close
Set File=Nothing
'Suche des Wortes in den Zeilen:
Hier=""
Zahl="0" 'Zahl der Fundstellen
For i=1 to Ende
k=1
Do until k>Len(Zeile(i))-Len(Wort)+1
If Mid(Zeile(i),k,Len(Wort))=Wort then
Hier=Hier&" | "&i
Zahl=Zahl+1 'Wie oft "Wort" gefunden ?
End If
k=k+1
Loop
Next
'Ende abschneiden !
If Len(Hier)>4 then Hier=Right(Hier,Int(Len(Hier)-3))
'Falls nichts zu finden war:
If Hier="" then MsgBox UV&VbCR&"Das Wort "" "&_
Wort&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Zeilen mit Nr. versehen:
For i=1 to Ende
Zeile(i)=i&VbTab&Zeile(i) 'VbTab gibt spaltenweise Anzeige, nicht " "!
Next
'Ausgabe der Fundstellen:
'MsgBox UV&UV&" Das Wort "" "&Wort&_
' " "" befindet sich in Zeile : "&UV&UV&_
' " "&Hier&UV&UV,VbInformation,Titel
'Aufsplittung der Fundorte in Ort( ), beginnt mit Ort(0) !
Ort=Split(Hier," | ")
'Ausgabedatei festlegen und gefundene Zeilen mit Nr. hinein schreiben:
Stamm=Fso.GetParentFolderName(Datei)
Datei=Fso.GetBaseName(Datei)&"-Such.txt"
Datei=Stamm&"/"&Datei
Set File=Fso.OpenTextFile(Datei,2,true)
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine("Das Wort "" "&Wort&" "" steht in folgenden Zeilen:")
File.WriteLine("************************************************")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
i=0
Do until i=Zahl 'Beginn mit i=0 !!
File.WriteLine(" ")
File.WriteLine(Zeile(Ort(i)))
i=i+1
Loop
File.Close
Set File=Nothing
'Bei Erfolg die Datei mit den Zeilen-Nr. anzeigen und diese löschen:
Wss.Run "Notepad """&Datei&""" "
WScript.Sleep 1500
'Frage, ob Ausgabe-Datei gelöscht werden soll:
Ask=MsgBox(UV&UV&_
"Soll diese Datei mit den Fundorten gelöscht werden ? "&_
UV&"Sie steht im Verzeichnis dieser aufgesetzten Datei!"&UV&_
UV,VbYesNo+VbDefaultButton2+VbCritical,Titel)
If Ask="7" then WScript.Quit ' Bei "Nein" Abbruch !
'Sonst die Fundort-Datei löschen:
WScript.Sleep 1000
Fso.DeleteFile Datei
#########################################################################
>>> dateinameninkleinbuchstaben.vbs <<<
'v3.5*****************************************************
' File: DateienMitKleinbuchstaben.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Alle Dateien in einem Verzeichnis erhalten gleichen
' Dateinamen wie bisher, aber mit Kleinbuchstaben.
'*********************************************************
Option Explicit
Dim WSHShell, fso
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, LaufW, Pfad, DateiX, VerzX
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
LaufW = Left( UCase( WScript.ScriptFullName), 2)
Pfad = LaufW & "\dieseyer.neu\scr\backup"
Pfad = LaufW & "\dieseyer.neu\scr"
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
i = i + 1
ReDim Preserve Datei(i)
Datei(i) = DateiX.Path
Next
Set oFiles = nothing
Set oFolders = nothing
' Datei-Array - Dateien
' 1. Datei nach *.?? umbenennen
' 2. Datei nach *.* mit Kleinbuchstaben umbenennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 1 to UBound( Datei )
set DateiX = fso.GetFile( Datei(i) )
DateiX.move ( Datei(i) & "-" )
set DateiX = nothing
set DateiX = fso.GetFile( Datei(i) & "-" )
DateiX.move ( LCase( Datei(i) ) )
set DateiX = nothing
Next
MsgBox "In " & Pfad & " wurden von " & i & vbCRLF & "Dateien der Dateiname in Kleinbuchstaben geändert."
#########################################################################
>>> dateinamenlangdir.vbs <<<
'*** v10.6 *** www.dieseyer.de *****************************
' 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.
'
' Neuu in v10.5: zu testendes Verzeichnis auf VBS ziehen und
' fallen lassen.
'
' Neu in v9.4: 'Browse For Folder', wenn die Variable
' "LaufWerk" leer ist.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Args : Set Args = Wscript.Arguments
Dim Tst, Text, i, iDatei, iVerz, iLang, iAnz, MaxAnz, LaufWerk, Modus1, Modus2, Zeit, DirTmp
Dim fo, fi
Dim LogDatei
iLang = 0
Modus1 = 0
Modus2 = 0
MaxAnz = 200
LaufWerk = ""
For i = 0 to Args.Count - 1 ' hole alle Argumente
LaufWerk = LaufWerk & " " & Args( i )
Next
LaufWerk = Trim( LaufWerk )
If LaufWerk = "" Then LaufWerk = BrowseForFolder( "Verzeichnis auswählen:", 9+16384, 0 )
' Pfad erreichbar?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FolderExists( Laufwerk ) Then
Else
MsgBox vbTab & "= = = F E H L E R = = =" & vbCRLF & vbCRLF & ">" & Laufwerk & "<" & vbCRLF & vbCRLF & vbTab & "ist nicht erreichbar!", , "045 :: " & WScript.ScriptName
WScript.Quit
End If
If Right( LaufWerk, 1 ) = "\" Then LaufWerk = Left( LaufWerk, Len( LaufWerk ) - 1 ) ' ohne \ am Ende
' LogDatei festlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogDatei = WScript.ScriptFullName
LogDatei = Left( LogDatei, InStrRev( LogDatei, "." ) - 1 )
' MsgBox LogDatei, , "056 :: " : WScript.Quit
If Mid( Laufwerk, 2, 1 ) = ":" Then
Tst = Mid( Laufwerk, 1, 1 ) & "-" & Mid( Laufwerk, InStrRev( Laufwerk, "\" ) + 1 )
Else
Tst = Mid( Laufwerk, InStrRev( Laufwerk, "\" ) + 1 )
End If
DirTmp = LogDatei & "_" & Tst & "_.tmp"
LogDatei = LogDatei & "_" & Tst & "_.log"
' MsgBox "LogDatei " & vbTab & LogDatei & vbCRLF & "DirTmp " & vbTab & DirTmp, , "064 :: " : WScript.Quit
Trace32Log "067 :: ++++ " & LaufWerk & " +++++++++++++++", 1
Trace32Log "068 :: DirTmp: '" & DirTmp & "'", 1
Zeit = Timer()
' Prüfen, ob in die DIR-Zieldatei noch geschrieben wird
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists( DirTmp )Then
Text = fso.GetFile( DirTmp ).Size
wshshell.Popup "Bitte nicht OK drücken!!!" , 3, "076 :: Nach 3sek bin ich weg!", vbExclamation
If not Text = fso.GetFile( DirTmp ).Size Then
MsgBox "Z.Z. wird Laufwerk " & vbCRLF & vbCRLF & LaufWerk & vbCRLF & vbCRLF & " noch geprüft . . .", 4096 + vbInformation, "078 :: " & WScript.ScriptName
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+4096, "083 :: " & 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!", , "093 :: " & WScript.ScriptName
If MaxAnz = "" Then WScript.Quit
MaxAnz = CInt(MaxAnz)
If Len( LaufWerk ) = 3 AND InStr( LaufWerk, ":\" ) = 2 Then
LaufWerk = Left( LaufWerk, 2 )
End If
Trace32Log "101 :: ++++ " & LaufWerk & " +++++++++++++++", 1
Trace32Log "102 :: Start " & now(), 1
Zeit = Timer()
' Neue DIR-Zieldatei wird erstellt
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = "%comspec% /c dir """ & LaufWerk & "\"" /s /b > """ & DirTmp & """"
' MsgBox Text, , "108 :: "
WSHShell.run Text, 0, True
Trace32Log "110 :: DIR-End - Dauer: " & Timer() - Zeit & "s", 1
' Neue DIR-Zieldatei zum Lesen öffnen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if not fso.FileExists( DirTmp) Then wshshell.Popup "Bitte nicht OK drücken!!!", 3, "114 :: Nach 3sek bin ich weg!", vbExclamation
' WSHShell.run "notepad """ & DirTmp & """", , True
' Neue DIR-Zieldatei zeilenweise lesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set fi = FSO.OpenTextFile( DirTmp, 1 ) ' 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
Trace32Log "127 :: Nr.: " & iLang & " Länge: " & len(Text) & " " & Text, 1 ' protokollieren
End If
Loop
fi.Close
Set fi = Nothing ' Datei schließen
' Text = iDatei & " Dateien auf Laufwerk " & LaufWerk & " wurden überprüft."
Trace32Log "134 :: " & iLang & " " & "Dateien haben mehr als " & MaxAnz & " Zeichen im Dateinamen . . .", 1
Trace32Log "135 :: " & iDatei & " " & "Dateien/Verzeichnissen auf Laufwerk " & LaufWerk & " wurden geprüft.", 1
Trace32Log "136 :: " & "Dauer: " & Timer() - Zeit & "s", 1
' Zeit = hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & secound(Zeit-now())
Trace32Log "140 :: Ende " & now() & " - Dauer: " & Timer() - Zeit & "s", 1
Trace32Log "142 :: ++++ " & LaufWerk & " +++++++++++++++", 1
WSHShell.run """" & LogDatei & """", , False
WScript.Sleep 1500
WSHShell.Sendkeys "^{End}"
WScript.Quit
'***********************************************************
Function ToANSI( ASCIIz )
'***********************************************************
' von Christoph Basedau aus
' http://groups.google.de/groups?q=ToANSI+%3D+Replace&hl=de&lr=&newwindow=1&selm=ugGVQok3AHA.1604%40tkmsftngp02&rnum=1
ToANSI = Replace(ASCIIz, chr(132), chr(228))
ToANSI = Replace(ToANSI, chr(129), chr(252))
ToANSI = Replace(ToANSI, chr(142), Chr(196))
ToANSI = Replace(ToANSI, chr(154), Chr(220))
ToANSI = Replace(ToANSI, chr(153), Chr(214))
ToANSI = Replace(ToANSI, chr(148), Chr(246))
ToANSI = Replace(ToANSI, chr(225), Chr(223))
End Function ' ToANSI( ASCIIz )
'*** v9.4 *** www.dieseyer.de ******************************
Function BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'***********************************************************
' http://www.codecomments.com/message367170.html
' http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_frm/thread/f083a8d1806e9a68/d835b2a1ec45afec?lnk=st&q=BrowseForFolder+strPrompt+intBrowseInfo+vRootFolder&rnum=1&hl=de#d835b2a1ec45afec
'
'BrowseForFolder dialog. Follows MSDN example closely. Also handles selection of special
'folders (ex Desktop), which do not return a folder3 object as 'normal' folders do.
'Code below does not support all options, only folders.
'To use, copy and paste function into script,
'call as BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder) where root folder is either an
'integer (constants below) or a string with a folder path.
'To use the constants below, they must be in the script header.
'Flags specifying the options for the dialog box. This member can include zero or a combination of the following values.
Const BIF_BROWSEFORCOMPUTER = 4096 'Only return computers. If the user selects anything other than a computer, the OK button is grayed.
Const BIF_BROWSEFORPRINTER = 8192 'Only allow the selection of printers. If the user selects anything other than a printer, the OK button is grayed. In Microsoft Windows XP, the best practice is to use an XP-style dialog, setting the root of the dialog to the Printers and Faxes folder (CSIDL_PRINTERS).
Const BIF_BROWSEINCLUDEFILES = 16384 'Version 4.71. The browse dialog box will display files as well as folders.
'Const BIF_BROWSEINCLUDEURLS = 'Version 5.0. The browse dialog box can display URLs. The BIF_USENEWUI and BIF_BROWSEINCLUDEFILES flags must also be set. If these three flags are not set, the browser dialog box will reject URLs. Even when these flags are set, the browse dialog box will only display URLs if the folder that contains the selected item supports them. When the folder's IShellFolder::GetAttributesOf method is called to request the selected item's attributes, the folder must set the SFGAO_FOLDER attribute flag. Otherwise, the browse dialog box will not display the URL.
Const BIF_DONTGOBELOWDOMAIN = 2 'Do not include network folders below the domain level in the dialog box's tree view control.
Const BIF_EDITBOX = 16 'Version 4.71. Include an edit control in the browse dialog box that allows the user to type the name of an item.
'Const BIF_NEWDIALOGSTYLE = 'Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_NONEWFOLDERBUTTON = 512 'Version 6.0. Do not include the New Folder button in the browse dialog box.
'Const BIF_NOTRANSLATETARGETS = 'Version 6.0. When the selected item is a shortcut, return the PIDL of the shortcut itself rather than its target.
Const BIF_RETURNFSANCESTORS = 8 'Only return file system ancestors. An ancestor is a subfolder that is beneath the root folder in the namespace hierarchy. If the user selects an ancestor of the root folder that is not part of the file system, the OK button is grayed. Const BIF_RETURNONLYFSDIRS = 1 'Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
'Const BIF_SHAREABLE = 'Version 5.0. The browse dialog box can display shareable resources on remote systems. It is intended for applications that want to expose remote shares on a local system. The BIF_NEWDIALOGSTYLE flag must also be set.
Const BIF_STATUSTEXT = 4 'Include a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. This flag is not supported when BIF_NEWDIALOGSTYLE is specified.
'Const BIF_UAHINT = 'Version 6.0. When combined with BIF_NEWDIALOGSTYLE, adds a usage hint to the dialog box in place of the edit box. BIF_EDITBOX overrides this flag.
'Const BIF_USENEWUI = 'Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE. To use BIF_USENEWUI, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_VALIDATE = 32 'Version 4.71. If the user types an invalid name into the edit box, the browse dialog box will call the application's BrowseCallbackProc with the BFFM_VALIDATEFAILED message. This flag is ignored if BIF_EDITBOX is not specified.
Const ssfALTSTARTUP = 29 'File system directory that corresponds to the user's nonlocalized Startup program group. (value = 29)
Const ssfAPPDATA = 26 'Version 4.71. File system directory that serves as a common repository for application-specific data. A typical path is C:\Documents and Settings\username\Application Data. (value = 26)
Const ssfBITBUCKET = 10 'Virtual folder containing the objects in the user's Recycle Bin. (value = 15)
Const ssfCOMMONALTSTARTUP = 30 'File system directory that corresponds to the nonlocalized Startup program group for all users. Valid only for Microsoft Windows NT systems. (value = 30)
Const ssfCOMMONAPPDATA = 35 'Version 5.0. Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data. (value = 35)
Const ssfCOMMONDESKTOPDIR = 25 'File system directory that contains files and folders that appear on the desktop for all users. A typical path is C:\Documents and Settings\All Users\Desktop. Valid only for Windows NT systems. (value = 25)
Const ssfCOMMONFAVORITES = 31 'File system directory that serves as a common repository for all users' favorite items. Valid only for Windows NT systems. (value = 31)
Const ssfCOMMONPROGRAMS = 23 'File system directory that contains the directories for the common program groups that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs. Valid only for Windows NT systems. (value = 23)
Const ssfCOMMONSTARTMENU = 22 'File system directory that contains the programs and folders that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu. Valid only for Windows NT systems. (value = 22)
Const ssfCOMMONSTARTUP = 24 'File system directory that contains the programs that appear in the Startup folder for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs\Startup. Valid only for Windows NT systems. (value = 24)
Const ssfCONTROLS = 3 'Virtual folder containing icons for the Control Panel applications. (value = 3)
Const ssfCOOKIES = 33 'File system directory that serves as a common repository for Internet cookies. A typical path is C:\Documents and Settings\username\Cookies. (value = 33)
Const ssfDESKTOP = 0 'Microsoft Windows Desktop—virtual folder that is the root of the namespace. (value = 0)
Const ssfDESKTOPDIRECTORY = 16 'File system directory used to physically store the file objects that are displayed on the desktop. It is not to be confused with the desktop folder itself, which is a virtual folder. A typical path is C:\Documents and Settings\username\Desktop. (value = 16)
Const ssfDRIVES = 17 'My Computer—virtual folder containing everything on the local computer: storage devices, printers, and Control Panel. This folder may also contain mapped network drives. (value = 17)
Const ssfFAVORITES = 6 'File system directory that serves as a common repository for the user's favorite items. A typical path is C:\Documents and Settings\username\Favorites. (value = 6)
Const ssfFONTS = 20 'Virtual folder containing installed fonts. A typical path is C:\WINNT\Fonts. (value = 20)
Const ssfHISTORY = 34 'File system directory that serves as a common repository for Internet history items. (value = 34)
Const ssfINTERNETCACHE = 32 'File system directory that serves as a common repository for temporary Internet files. A typical path is C:\Documents and Settings\username\Temporary Internet Files. (value = 32)
Const ssfLOCALAPPDATA = 28 'Version 5.0. File system directory that serves as a data repository for local (non-roaming) applications. A typical path is C:\Documents and Settings\username\Local Settings\Application Data. (value = 28)
Const ssfMYPICTURES = 39 'My Pictures folder. A typical path is C:\Documents and Settings\username\My Documents\My Pictures. (value = 39)
Const ssfNETHOOD = 19 'A file system folder containing the link objects that may exist in the My Network Places virtual folder. It is not the same as ssfNETWORK, which represents the network namespace root. A typical path is C:\Documents and Settings\username\NetHood. (value = 19)
Const ssfNETWORK = 21 'Network Neighborhood—virtual folder representing the root of the network namespace hierarchy. (value = 18)
Const ssfPERSONAL = 5 'File system directory that serves as a common repository for a user's documents. A typical path is C:\Documents and Settings\username\My Documents. (value = 5)
Const ssfPRINTERS = 4 'Virtual folder containing installed printers. (value = 4)
Const ssfPRINTHOOD = 18 'File system directory that contains the link objects that may exist in the Printers virtual folder. A typical path is C:\Documents and Settings\username\PrintHood. (value = 27)
Const ssfPROFILE = 40 'Version 5.0. User's profile folder. (value = 40)
Const ssfPROGRAMFILES = 38 'Version 5.0. Program Files folder. A typical path is C:\Program Files. (value = 38)
Const ssfPROGRAMS = 2 'File system directory that contains the user's program groups (which are also file system directories). A typical path is C:\Documents and Settings\username\Start Menu\Programs. (value = 2)
Const ssfRECENT = 8 'File system directory that contains the user's most recently used documents. A typical path is C:\Documents and Settings\username\Recent. (value = 8)
Const ssfSENDTO = 9 'File system directory that contains Send To menu items. A typical path is C:\Documents and Settings\username\SendTo. (value = 9)
Const ssfSTARTMENU = 11 'File system directory containing Start menu items. A typical path is C:\Documents and Settings\username\Start Menu. (value = 11)
Const ssfSTARTUP = 7 'File system directory that corresponds to the user's Startup program group. The system starts these programs whenever any user logs onto Windows NT or starts Windows 95. A typical path is C:\Documents and Settings\username\Start Menu\Programs\Startup. (value = 7)
Const ssfSYSTEM = 37 'Version 5.0. System folder. A typical path is C:\WINNT\SYSTEM32. (value = 37)
Const ssfTEMPLATES = 21 'File system directory that serves as a common repository for document templates. (value = 21)
Const ssfWINDOWS = 36 'Version 5.0. Windows directory or SYSROOT. This corresponds to the %windir% or %SYSTEMROOT% environment variables. A typical path is C:\WINNT. (value = 36)
Dim oShell
Dim oFolder
Dim oFolderItem
Dim strPath
Dim oWSHShell
Dim oFSO
Dim bSuccess
Dim errTst
Set oShell = CreateObject("Shell.Application")
Set oWSHShell = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
'syntax: oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [,vRootFolder])
Set oFolder = oShell.BrowseForFolder(&H0, strPrompt, intBrowseInfo, vRootFolder)
On Error Resume Next
'This seems to get a 'normal' folder object from the folder3 object returned by BrowseForFolder
Set oFolderItem = oFolder.Items.Item
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
' MsgBox "Invalid selection; Please try again", , "255 :: " & WScript.ScriptName
Else
'If a special folder (ex. desktop) is selected, object is nothing.
If (oFolderItem Is Nothing) Then
'This is necessary - seems to convert invalid object reference to a string?
strPath = oFolder
Set oFolderItem = oFSO.GetFolder(oWSHShell.SpecialFolders(strPath))
End If
End If
On Error Resume Next
If Not oFSO.FolderExists(oFolderItem.Path) Then
On Error GoTo 0
MsgBox "Invalid selection; Please try again", , "270 :: " & WScript.ScriptName
Else
bSuccess = True
End If
Loop While Not bSuccess
BrowseForFolder = oFolderItem.Path
End Function ' BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "365 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "366 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> dateinamenlangdir2.vbs <<<
'v5.5*****************************************************
' File: DateiNamenLangDIR2.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverzeichnis nach Dateien, deren Name inkl.
' kompletter Pfadangabe länger als 200 Zeichen ist.
' Das Skript prüft, ob es bereist läuft.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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:"
LaufWerk = "\\pc-amd\dateien$"
MaxAnz = 200
Text = Text & "Welcher Laufwerkspfad 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 & ".dir"
' 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 "Dieses Skript läuft z.Z. noch (mit einer Prüfung).", , WScript.ScriptName
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 ) ' 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
WScript.Sleep( 666 )
WSHShell.run "notepad " & WScript.ScriptName & ".log"
WScript.Sleep( 666 )
WSHShell.Sendkeys "^{End}"
WScript.Quit
'*********************************************************
Function ToANSI( ASCIIz )
'*********************************************************
' von Christoph Basedau aus
' http://groups.google.de/groups?q=ToANSI+%3D+Replace&hl=de&lr=&newwindow=1&selm=ugGVQok3AHA.1604%40tkmsftngp02&rnum=1
ToANSI = Replace(ASCIIz, chr(132), chr(228))
ToANSI = Replace(ToANSI, chr(129), chr(252))
ToANSI = Replace(ToANSI, chr(142), Chr(196))
ToANSI = Replace(ToANSI, chr(154), Chr(220))
ToANSI = Replace(ToANSI, chr(153), Chr(214))
ToANSI = Replace(ToANSI, chr(148), Chr(246))
ToANSI = Replace(ToANSI, chr(225), Chr(223))
End Function ' ToANSI( ASCIIz )
'*********************************
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
#########################################################################
>>> dateinamenlangvbs.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' 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.
' Seit v9.4 mit 'Browse For Folder', wenn die Variable
' "LaufWerk" leer ist.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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
MaxAnz = 200
LaufWerk = "d:\"
LaufWerk = ""
If LaufWerk = "" Then LaufWerk = BrowseForFolder( "Verzeichnis auswählen:", 9+16384, 0 )
Text = Text & "Welches Laufwerk soll auf zu lange Dateiennamen (>"
Text = Text & MaxAnz & " Zeichen) getestet werden?"
' Pfad erreichbar?
' -------------------------------------------------
If fso.FolderExists( Laufwerk ) Then
Else
Text = "Für " & LaufWerk & " gilt:" & vbCRLF & vbCRLF & Text & " !"
MsgBox vbTab & "= = = F E H L E R = = =" & Laufwerk & vbCRLF & vbCRLF & "ist nicht erreichbar!", , "039 :: " & 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.GetBaseName( LaufWerk ) & "_" & ".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, "052 :: " & WScript.ScriptName
if not Text = fso.GetFile( TmpTmp ).Size Then
MsgBox "Z.Z. wird Laufwerk " & LaufWerk & " noch geprüft.", , "054 :: " & WScript.ScriptName
WScript.Quit
Else
Text = "Laufwerk " & LaufWerk & " wurde bereits geprüft. "
Text = Text & "Soll eine neue Liste erstellt werden?"
i = MsgBox( Text, 3+32+256, , "059 :: " & 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!", , "069 :: " & WScript.ScriptName
If MaxAnz = "" then WScript.Quit
MaxAnz = CInt(MaxAnz)
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now()
Zeit = Timer()
' MsgBox LaufWerk, , "075 :: " & WScript.ScriptName
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." & vbCRLF
Text = Text & vbTab & "Dauer: " & Timer() - Zeit & "s"
LogDatei "Nr." & vbTab & "Länge" & vbTab & "DateiName" & vbCRLF & Text
LogDatei "Stop " & now() & " - Dauer: " & Timer() - Zeit & "s"
MsgBox Text, , "085 :: " & WScript.ScriptName
LogDatei "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF
WSHShell.run "notepad.exe """ & WScript.ScriptName & ".log"""
WScript.Sleep 1500
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
' MsgBox path & vbCRLF & "i: " & i, , "101 :: " & WScript.ScriptName
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, "108 :: " & 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, "116 :: " & 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, "126 :: " & 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
'*** v9.4 *** www.dieseyer.de ******************************
Function BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'***********************************************************
' http://www.codecomments.com/message367170.html
' http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_frm/thread/f083a8d1806e9a68/d835b2a1ec45afec?lnk=st&q=BrowseForFolder+strPrompt+intBrowseInfo+vRootFolder&rnum=1&hl=de#d835b2a1ec45afec
'
'BrowseForFolder dialog. Follows MSDN example closely. Also handles selection of special
'folders (ex Desktop), which do not return a folder3 object as 'normal' folders do.
'Code below does not support all options, only folders.
'To use, copy and paste function into script,
'call as BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder) where root folder is either an
'integer (constants below) or a string with a folder path.
'To use the constants below, they must be in the script header.
'Flags specifying the options for the dialog box. This member can include zero or a combination of the following values.
Const BIF_BROWSEFORCOMPUTER = 4096 'Only return computers. If the user selects anything other than a computer, the OK button is grayed.
Const BIF_BROWSEFORPRINTER = 8192 'Only allow the selection of printers. If the user selects anything other than a printer, the OK button is grayed. In Microsoft Windows XP, the best practice is to use an XP-style dialog, setting the root of the dialog to the Printers and Faxes folder (CSIDL_PRINTERS).
Const BIF_BROWSEINCLUDEFILES = 16384 'Version 4.71. The browse dialog box will display files as well as folders.
'Const BIF_BROWSEINCLUDEURLS = 'Version 5.0. The browse dialog box can display URLs. The BIF_USENEWUI and BIF_BROWSEINCLUDEFILES flags must also be set. If these three flags are not set, the browser dialog box will reject URLs. Even when these flags are set, the browse dialog box will only display URLs if the folder that contains the selected item supports them. When the folder's IShellFolder::GetAttributesOf method is called to request the selected item's attributes, the folder must set the SFGAO_FOLDER attribute flag. Otherwise, the browse dialog box will not display the URL.
Const BIF_DONTGOBELOWDOMAIN = 2 'Do not include network folders below the domain level in the dialog box's tree view control.
Const BIF_EDITBOX = 16 'Version 4.71. Include an edit control in the browse dialog box that allows the user to type the name of an item.
'Const BIF_NEWDIALOGSTYLE = 'Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_NONEWFOLDERBUTTON = 512 'Version 6.0. Do not include the New Folder button in the browse dialog box.
'Const BIF_NOTRANSLATETARGETS = 'Version 6.0. When the selected item is a shortcut, return the PIDL of the shortcut itself rather than its target.
Const BIF_RETURNFSANCESTORS = 8 'Only return file system ancestors. An ancestor is a subfolder that is beneath the root folder in the namespace hierarchy. If the user selects an ancestor of the root folder that is not part of the file system, the OK button is grayed. Const BIF_RETURNONLYFSDIRS = 1 'Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
'Const BIF_SHAREABLE = 'Version 5.0. The browse dialog box can display shareable resources on remote systems. It is intended for applications that want to expose remote shares on a local system. The BIF_NEWDIALOGSTYLE flag must also be set.
Const BIF_STATUSTEXT = 4 'Include a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. This flag is not supported when BIF_NEWDIALOGSTYLE is specified.
'Const BIF_UAHINT = 'Version 6.0. When combined with BIF_NEWDIALOGSTYLE, adds a usage hint to the dialog box in place of the edit box. BIF_EDITBOX overrides this flag.
'Const BIF_USENEWUI = 'Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE. To use BIF_USENEWUI, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_VALIDATE = 32 'Version 4.71. If the user types an invalid name into the edit box, the browse dialog box will call the application's BrowseCallbackProc with the BFFM_VALIDATEFAILED message. This flag is ignored if BIF_EDITBOX is not specified.
Const ssfALTSTARTUP = 29 'File system directory that corresponds to the user's nonlocalized Startup program group. (value = 29)
Const ssfAPPDATA = 26 'Version 4.71. File system directory that serves as a common repository for application-specific data. A typical path is C:\Documents and Settings\username\Application Data. (value = 26)
Const ssfBITBUCKET = 10 'Virtual folder containing the objects in the user's Recycle Bin. (value = 15)
Const ssfCOMMONALTSTARTUP = 30 'File system directory that corresponds to the nonlocalized Startup program group for all users. Valid only for Microsoft Windows NT systems. (value = 30)
Const ssfCOMMONAPPDATA = 35 'Version 5.0. Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data. (value = 35)
Const ssfCOMMONDESKTOPDIR = 25 'File system directory that contains files and folders that appear on the desktop for all users. A typical path is C:\Documents and Settings\All Users\Desktop. Valid only for Windows NT systems. (value = 25)
Const ssfCOMMONFAVORITES = 31 'File system directory that serves as a common repository for all users' favorite items. Valid only for Windows NT systems. (value = 31)
Const ssfCOMMONPROGRAMS = 23 'File system directory that contains the directories for the common program groups that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs. Valid only for Windows NT systems. (value = 23)
Const ssfCOMMONSTARTMENU = 22 'File system directory that contains the programs and folders that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu. Valid only for Windows NT systems. (value = 22)
Const ssfCOMMONSTARTUP = 24 'File system directory that contains the programs that appear in the Startup folder for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs\Startup. Valid only for Windows NT systems. (value = 24)
Const ssfCONTROLS = 3 'Virtual folder containing icons for the Control Panel applications. (value = 3)
Const ssfCOOKIES = 33 'File system directory that serves as a common repository for Internet cookies. A typical path is C:\Documents and Settings\username\Cookies. (value = 33)
Const ssfDESKTOP = 0 'Microsoft Windows Desktop—virtual folder that is the root of the namespace. (value = 0)
Const ssfDESKTOPDIRECTORY = 16 'File system directory used to physically store the file objects that are displayed on the desktop. It is not to be confused with the desktop folder itself, which is a virtual folder. A typical path is C:\Documents and Settings\username\Desktop. (value = 16)
Const ssfDRIVES = 17 'My Computer—virtual folder containing everything on the local computer: storage devices, printers, and Control Panel. This folder may also contain mapped network drives. (value = 17)
Const ssfFAVORITES = 6 'File system directory that serves as a common repository for the user's favorite items. A typical path is C:\Documents and Settings\username\Favorites. (value = 6)
Const ssfFONTS = 20 'Virtual folder containing installed fonts. A typical path is C:\WINNT\Fonts. (value = 20)
Const ssfHISTORY = 34 'File system directory that serves as a common repository for Internet history items. (value = 34)
Const ssfINTERNETCACHE = 32 'File system directory that serves as a common repository for temporary Internet files. A typical path is C:\Documents and Settings\username\Temporary Internet Files. (value = 32)
Const ssfLOCALAPPDATA = 28 'Version 5.0. File system directory that serves as a data repository for local (non-roaming) applications. A typical path is C:\Documents and Settings\username\Local Settings\Application Data. (value = 28)
Const ssfMYPICTURES = 39 'My Pictures folder. A typical path is C:\Documents and Settings\username\My Documents\My Pictures. (value = 39)
Const ssfNETHOOD = 19 'A file system folder containing the link objects that may exist in the My Network Places virtual folder. It is not the same as ssfNETWORK, which represents the network namespace root. A typical path is C:\Documents and Settings\username\NetHood. (value = 19)
Const ssfNETWORK = 21 'Network Neighborhood—virtual folder representing the root of the network namespace hierarchy. (value = 18)
Const ssfPERSONAL = 5 'File system directory that serves as a common repository for a user's documents. A typical path is C:\Documents and Settings\username\My Documents. (value = 5)
Const ssfPRINTERS = 4 'Virtual folder containing installed printers. (value = 4)
Const ssfPRINTHOOD = 18 'File system directory that contains the link objects that may exist in the Printers virtual folder. A typical path is C:\Documents and Settings\username\PrintHood. (value = 27)
Const ssfPROFILE = 40 'Version 5.0. User's profile folder. (value = 40)
Const ssfPROGRAMFILES = 38 'Version 5.0. Program Files folder. A typical path is C:\Program Files. (value = 38)
Const ssfPROGRAMS = 2 'File system directory that contains the user's program groups (which are also file system directories). A typical path is C:\Documents and Settings\username\Start Menu\Programs. (value = 2)
Const ssfRECENT = 8 'File system directory that contains the user's most recently used documents. A typical path is C:\Documents and Settings\username\Recent. (value = 8)
Const ssfSENDTO = 9 'File system directory that contains Send To menu items. A typical path is C:\Documents and Settings\username\SendTo. (value = 9)
Const ssfSTARTMENU = 11 'File system directory containing Start menu items. A typical path is C:\Documents and Settings\username\Start Menu. (value = 11)
Const ssfSTARTUP = 7 'File system directory that corresponds to the user's Startup program group. The system starts these programs whenever any user logs onto Windows NT or starts Windows 95. A typical path is C:\Documents and Settings\username\Start Menu\Programs\Startup. (value = 7)
Const ssfSYSTEM = 37 'Version 5.0. System folder. A typical path is C:\WINNT\SYSTEM32. (value = 37)
Const ssfTEMPLATES = 21 'File system directory that serves as a common repository for document templates. (value = 21)
Const ssfWINDOWS = 36 'Version 5.0. Windows directory or SYSROOT. This corresponds to the %windir% or %SYSTEMROOT% environment variables. A typical path is C:\WINNT. (value = 36)
Dim oShell
Dim oFolder
Dim oFolderItem
Dim strPath
Dim oWSHShell
Dim oFSO
Dim bSuccess
Dim errTst
Set oShell = CreateObject("Shell.Application")
Set oWSHShell = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
'syntax: oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [,vRootFolder])
Set oFolder = oShell.BrowseForFolder(&H0, strPrompt, intBrowseInfo, vRootFolder)
On Error Resume Next
'This seems to get a 'normal' folder object from the folder3 object returned by BrowseForFolder
Set oFolderItem = oFolder.Items.Item
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
' MsgBox "Invalid selection; Please try again", , "242 :: " & WScript.ScriptName
Else
'If a special folder (ex. desktop) is selected, object is nothing.
If (oFolderItem Is Nothing) Then
'This is necessary - seems to convert invalid object reference to a string?
strPath = oFolder
Set oFolderItem = oFSO.GetFolder(oWSHShell.SpecialFolders(strPath))
End If
End If
On Error Resume Next
If Not oFSO.FolderExists(oFolderItem.Path) Then
On Error GoTo 0
MsgBox "Invalid selection; Please try again", , "257 :: " & WScript.ScriptName
Else
bSuccess = True
End If
Loop While Not bSuccess
BrowseForFolder = oFolderItem.Path
End Function ' BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
#########################################################################
>>> dateinamespeichern.vbs <<<
'v2.9********************************************************
' File: DateiNameSpeichern.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Mit der Maus 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 Maus-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 Maus 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
#########################################################################
>>> dateisichernbak.vbs <<<
'*** v8.2 *** www.dieseyer.de *******************************
'
' Datei: dateisichernbak.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Das Problem: Ein Server schreibt eine .LOG-Datei. Sobald
' diese größer als 1 MByte ist, wird sie in. *.bak umbenannt
' und dabei die alte .BAK-Datei überschrieben - das geschieht
' ca. alle zwei Tage. Das Skript prüft nun stündlich das
' Dateidatum (DateLastModified) dieser .BAK-Datei und sobald
' sich dieses ändert, wird eine Kopie 'sicher gestellt'.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup "= = = S T A R T = = =", 2, "034 :: " & WScript.ScriptName
LogEintrag "035 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "036 :: LogDatei: " & LogDatei
LogEintrag "037 :: PCname: " & WSHNet.ComputerName
LogEintrag "038 :: Angemeldeter User: " & WSHNet.UserName
Const BakDatei1 = "C:\k6logs\sysinfo.bak"
Const BakDatei2 = "C:\k6logs\k6.bak"
Const SicherVerz1 = "C:\INFECTED\1"
Const SicherVerz2 = "C:\INFECTED\2"
Dim Tst
Do
' WScript.Sleep 1000 ' neue Sekunde abwarten
Do ' warten, bis eine neue Minute (mit xx:yy:00) anfängt
WScript.Sleep 20
If InStr( now(), ":00" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":10" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":20" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":30" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":40" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":50" ) = Len( now() ) - 2 Then Exit Do
Loop
If InStr( now(), ":13:0" ) > 0 Then ' in jeder Stunde zur 13. Minute
Tst = BakDateiSichern( BakDatei1, SicherVerz1 )
If Len( Tst ) > 3 Then
LogEintrag "063 :: Gesichert (" & BakDatei1 & ") nach " & Tst
Else
LogEintrag "065 :: Nicht gesichert: " & BakDatei1
End If
End If
If InStr( now(), ":17:0" ) > 0 Then ' in jeder Stunde zur 17. Minute
Tst = BakDateiSichern( BakDatei2, SicherVerz2 )
If Len( Tst ) > 3 Then
LogEintrag "072 :: Gesichert (" & BakDatei2 & ") nach " & Tst
Else
LogEintrag "074 :: Nicht gesichert: " & BakDatei2
End If
End If
If InStr( now(), "9:0" ) > 0 Then ' alle 10min; 09, 19, 29, 39, 49, 59
Tst = BakDateiSichern( BakDatei2, SicherVerz2 )
If Len( Tst ) > 3 Then LogEintrag "080 :: Gesichert (" & BakDatei2 & ") nach " & Tst
End If
If InStr( now(), "8:0" ) OR InStr( now(), "3:0" ) > 0 Then ' alle 5min; 03, 08, 13, 18, ...
Tst = BakDateiSichern( BakDatei2, SicherVerz2 )
If Len( Tst ) > 3 Then LogEintrag "085 :: Gesichert (" & BakDatei2 & ") nach " & Tst
End If
If InStr( now(), "6:0" ) OR InStr( now(), "1:0" ) > 0 Then ' alle 5min; 01, 06, 11, 16, ...
Tst = BakDateiSichern( BakDatei1, SicherVerz1 )
If Len( Tst ) > 3 Then
LogEintrag "091 :: Gesichert (" & BakDatei1 & ") nach " & Tst
Else
LogEintrag "093 :: Nicht gesichert: " & BakDatei1
End If
End If
' Tst = ""
' Tst = BakDateiSichern( BakDatei2, SicherVerz2 ) ' bei jedem Durchlauf'
' If Len( Tst ) > 3 Then
' LogEintrag "100 :: Gesichert (" & BakDatei2 & ") nach " & Tst
' Else
' LogEintrag "102 :: Nicht gesichert: " & BakDatei2
' End If
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
' LogEintrag "106 :: VBSmodTest: " & VBSmodTest
WScript.Sleep 1000 ' neue Sekunde abwarten
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "111 :: " & WScript.ScriptName
LogEintrag "112 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
Wscript.Quit
'*** v8.2 *** www.dieseyer.de *******************************
Function BakDateiSichern( BakDatei, ZielVerz )
'************************************************************
' prüft, ob eine neuere BackDatei als die letzte vorhanden
' existiert - wenn ja, wird die neue gesichert
' On Error Resume Next
' Am Ende von ZielVerz soll ein "\" sein!
If not InStrRev( ZielVerz, "\" ) = Len( ZielVerz ) Then ZielVerz = ZielVerz & "\"
' LogEintrag "127 :: Start: ""Function BakDateiSichern( " & BakDatei & ", " & ZielVerz & " )"" "
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim DateiNr : DateiNr = 0
Dim i
Dim ZielDatei, ZielEndg, DateiDatum
Dim arrDateiLst
Dim NeuereBakDatei : NeuereBakDatei = "JA"
BakDateiSichern = ""
If fso.FileExists( BakDatei ) Then
' LogEintrag "139 :: Zu kopierende BakDatei (QuellDatei) existiert: " & BakDatei
Else
LogEintrag "141 :: Zu kopierende BakDatei (QuellDatei) fehlt: " & BakDatei
LogEintrag "142 :: Exit: ""Function BakDateiSichern( " & BakDatei & ", " & ZielVerz & " )"" "
Exit Function
End If
' LogEintrag "146 :: BakDatei (QuellDatei): " & BakDatei
ZielDatei = ZielVerz & fso.GetBaseName( BakDatei ) & "_" ' ohne Endung
ZielEndg = "." & fso.GetExtensionName( BakDatei )
DateiDatum = fso.GetFile( BakDatei ).DateLastModified
' LogEintrag "150 :: ZielDatei: " & ZielDatei : LogEintrag "150 :: ZielEndg: " & ZielEndg : LogEintrag "150 :: DateiDatum: " & DateiDatum
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( ZielVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' LogEintrag "156 :: UBound( arrDateiLst ): " & UBound( arrDateiLst ) & " - also " & UBound( arrDateiLst ) + 1 & " Dateien."
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
' letzte vergebene Lfd.Nr. ermitteln und letztes Änderungsdatum im ZielVerz vergleichen
' LogEintrag "161 :: Testen auf richtige ZielDatei: " & arrDateiLst(i)
If InStr( arrDateiLst(i), ZielDatei ) = 1 Then
' LogEintrag "163 :: Richtiger ZielDatei-Name: " & arrDateiLst(i)
If UCase( Mid( arrDateiLst(i), InStrRev( arrDateiLst(i), "." ) ) ) = UCase( ZielEndg ) Then
' bereits gesicherte Datei gefunden
' LogEintrag "166 :: Richtige ZielDatei-Endung: " & arrDateiLst(i)
' Lfd.Nr. herauslösen; wenn größer als die letzte entdeckte, merken
Tst = Replace( UCase( arrDateiLst(i) ), UCase( ZielDatei ), "" )
Tst = Replace( Tst, UCase( ZielEndg ), "" ) : Tst = Int( Tst )
If Tst > DateiNr Then DateiNr = Tst ' letzte Lfd. Nr wird ermittelt
' LogEintrag "172 :: DateiNr: " & DateiNr
' Dateiänderungsdatumvergleichen
If NeuereBakDatei = "JA" AND DateiDatum = fso.GetFile( arrDateiLst(i) ).DateLastModified Then NeuereBakDatei = "-JA"
' LogEintrag "176 :: " & DateiDatum & " =?= " & fso.GetFile( arrDateiLst(i) ).DateLastModified
' LogEintrag "177 :: NeuereBakDatei: " & NeuereBakDatei
End If
End If
Next
If NeuereBakDatei = "JA" Then
' LogEintrag "184 :: (BakDatei) muss gesichert werden: " & BakDatei
Else
' LogEintrag "186 :: BakDatei ist nicht neuer als eine vorhande - Exit Function"
Exit Function
End If
DateiNr = DateiNr + 1
If Len( DateiNr ) < 3 Then DateiNr = "0" & DateiNr
If Len( DateiNr ) < 3 Then DateiNr = "0" & DateiNr
ZielDatei = ZielDatei & DateiNr & ZielEndg
fso.CopyFile BakDatei, ZielDatei
' LogEintrag "196 :: Zu kopieren (BakDatei) : " & BakDatei
' LogEintrag "197 :: Erstellte ZielDatei: " & ZielDatei
BakDateiSichern = ZielDatei & " (" & DateiDatum & ")"
' LogEintrag "200 :: Ende: BakDateiSichern = """ & BakDateiSichern & """ "
End Function ' BakDateiSichern( BakDatei, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
' LogEintrag "221 :: Ausgeschl: " & Ausgeschl
' LogEintrag "222 :: Verz: " & Verz
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
ReDim Preserve DateilisteholenX(i)
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "232 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v5.A *** www.dieseyer.de *******************************
Sub VBSbeenden()
'************************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
LogEintrag( "262 :: " & WScript.ScriptFullName & " existiert nicht!" )
LogEintrag( "263 :: " & WScript.ScriptFullName & " wird beendet . . . " & vbCRLF )
LogEintrag( "264 :: " & WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . " & vbCRLF )
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "266 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de *******************************
Sub VBSneustart()
'************************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "293 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "298 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "303 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v7.C *** www.dieseyer.de *******************************
Sub LogEintrag( LogTxt )
'************************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> dateispeichernunter.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: dateispeichernunter.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit
Dim Txt
Txt = "1. Zeile" & vbCRLF
Txt = Txt & "2. Zeile" & vbCRLF
Txt = Txt & "3. Zeile" & vbCRLF
Txt = Txt & "4. Zeile" & vbCRLF
Dim ZielDatei : ZielDatei = "Zeilen.txt"
Call DatenInDateiSpeichernunter( ZielDatei, Txt )
CreateObject("WScript.Shell").Run "notepad " & ZielDatei, , False
Wscript.Quit
'*** v9.3 *** www.dieseyer.de ******************************
Sub DatenInDateiSpeichernunter( Datei, Txt )
'***********************************************************
Dim RC
Dim objDialog
Set objDialog = CreateObject("SAFRCFileDlg.FileSave")
objDialog.FileName = Datei
objDialog.FileType = "LST Dateien(*.lst)"
RC = objDialog.OpenFileSaveDlg
If RC Then CreateObject("Scripting.FileSystemObject").CreateTextFile( objDialog.FileName ).Write Txt
End Sub ' DatenInDateiSpeichernunter( Datei, Txt )
#########################################################################
>>> dateitypregistrieren.vbs <<<
'*** v9.5 *** www.dieseyer.de ******************************
'
' Datei: DateiTypRegistrieren.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Sub-Prozedur
' DateiTypRegistrieren( DateiTyp, Progr )
' legt ein Programm als Standard-Anwendung für einen
' Dateityp fest (Dateiendung registrieren). Bei einem
' Doppelklick auf eine Datei mit dieser Dateiendung öffnet
' sich künftig diese Anwendung und erhält als Parameter die
' doppelt geklickte Datei - so, wie Word geöffnet wird, wenn
' man eine .doc - Datei doppelt klickt.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Const TestEndung = "n-p"
Const TestProgr = "notepad.exe"
Dim TestDatei : TestDatei = WScript.ScriptFullName & "." & TestEndung
Dim Txt, Tst
Txt = ""
Txt = Txt & "Als erstes wird eine Datei mit der Endung '." & TestEndung & "' erstellt. Im Anschluß" & vbCRLF
Txt = Txt & "daran wird als Standard-Anwendung für '." & TestEndung & "'' - Dateien 'notepad'" & vbCRLF
Txt = Txt & "festgelegt (Dateiendung registrieren) und dann die '." & TestEndung & "'' - Datei" & vbCRLF
Txt = Txt & "gestartet - es sollte sich 'notepad' mit diesem Text öffnen." & vbCRLF & vbCRLF
Txt = Txt & "Mit dem Schließen von Notepad wird die registrierte Dateiendung " & vbCRLF
Txt = Txt & "wieder entfernt." & vbCRLF & vbCRLF
Txt = Txt & "Und? Soll 's los gehen?"
' Kontroll-Frage
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = MsgBox( Txt, vbQuestion + vbOkCancel, "038 :: " & WScript.ScriptName )
If not Tst = vbOK Then MsgBox " . . . dann eben nicht!", , "040 :: " & WScript.ScriptName : WScript.Quit
' Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("Scripting.FileSystemObject").OpenTextFile( TestDatei, 2, True).Write Txt
' Datei starten - es muss eine Fehlermeldung folgen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WScript.CreateObject("WScript.Shell").Run TestDatei, , True
Call DateiTypRegistrieren( TestEndung, TestProgr )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Datei starten - keine Fehlermeldung
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Run TestDatei, , True
WScript.Quit
'*** v9.5 *** www.dieseyer.de ******************************
Sub DateiTypRegistrieren( DateiTyp, Progr )
'***********************************************************
' in VBS und HTA verwendbar
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim ZielProgr : ZielProgr = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\dieseyer.de\" & fso.GetFileName( Progr )
Dim Zielverz : Zielverz = fso.GetParentFolderName( ZielProgr )
Dim HilfsProgr : HilfsProgr = ""
If fso.GetExtensionName( LCase( Progr ) ) = "vbs" Then HilfsProgr = "wscript.exe "
If fso.GetExtensionName( LCase( Progr ) ) = "hta" Then HilfsProgr = "mshta.exe "
DateiTyp = LCase( DateiTyp )
Dim Txt, Tst
Trace32Log "082 :: DateiTyp: " & DateiTyp, 1
Trace32Log "083 :: Progr: " & Progr, 1
Trace32Log "084 :: HilfsProgr: " & HilfsProgr, 1
Trace32Log "085 :: DateiTyp: " & DateiTyp, 1
Trace32Log "086 :: Zielverz: " & Zielverz, 1
' Ziel-Verzeichnis für das Progr ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FolderExists( Zielverz ) Then
Else
Trace32Log "092 :: Zielverz soll anlegt werden: " & Zielverz, 1
On Error Resume Next
fso.CreateFolder Zielverz
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Verzeichnis kann nicht ertellt werden:" & vbCRLF & vbCRLF & Tst
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "099 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "100 :: Verzeichnis kann nicht ertellt werden: " & Zielverz & " _ " & Tst, 3
Trace32Log "101 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "104 :: Erstellt: " & Zielverz & " _ " & Tst, 1
End If
End If
' Wenn Progr erreichbar, Prog ins Ziel-Verzeichnis kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn Progr NICHT erreichbar ist, wird davon ausgegangen,
' dass das Prog über die Umgebungsvariable PATH vom
' Betriebssystem gefunden wird.
If not fso.FileExists( Progr ) Then
ZielProgr = Progr
Trace32Log "115 :: ZielProgr (evtl. neu) festgelegt: " & ZielProgr, 1
Else
Trace32Log "117 :: Datei soll kopiert werden: (von..nach)", 1
Trace32Log "118 :: " & Progr, 1
Trace32Log "119 :: " & ZielProgr, 1
On Error Resume Next
fso.CopyFile Progr, ZielProgr, true
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Datei kann nicht ertellt werden:" & vbCRLF & vbCRLF & ZielProgr
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "126 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "127 :: Kann nicht erstellt werden: " & ZielProgr & " _ " & Tst, 3
Trace32Log "128 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "131 :: Erstellt: " & ZielProgr & " _ " & Tst, 1
End If
End If
Txt = "HKLM\SOFTWARE\Classes\." & DateiTyp & "\"
WSHShell.RegWrite Txt, DateiTyp & "_auto_file"
Trace32Log "137 :: RegWrite erfolgreich: " & Txt, 1
Txt = "HKLM\SOFTWARE\Classes\" & DateiTyp & "_auto_file\shell\open\command\"
WSHShell.RegWrite Txt, HilfsProgr & """" & ZielProgr & """ " & chr(34) & "%1" & chr(34)
Trace32Log "141 :: RegWrite erfolgreich: " & Txt, 1
Txt = vbTab & ZielProgr & vbCRLF & vbCRLF
Txt = Txt & "wurde als Standard-Anwendung für '" & DateiTyp & "' -Dateien registriert." & vbCRLF & vbCRLF
Txt = Txt & "Künftig genügt es, eine Datei mit der Endung ." & DateiTyp & " doppelt an zu" & vbCRLF
Txt = Txt & "klicken und die Anwendung startet mit dieser Datei als Parameter. " & vbCRLF
WSHShell.PopUp Txt, 30, "147 :: Sub 'DateiTypRegistrieren'", vbInformation
Trace32Log "149 :: Ende - Sub 'DateiTypRegistrieren'", 1
End Sub ' DateiTypRegistrieren( DateiTyp, Progr )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 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 FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oArgs : 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 ) ' Datei zum Lesen öffnen
i = 0 : ReDim Preserve Zeile(i)
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = UBound( Zeile ) + 1 : ReDim Preserve Zeile(i) : Zeile(i) = FileIn.Readline
Loop
If UBound( Zeile ) < 1 Then
i = UBound( Zeile ) : 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 = LBound( Zeile ) 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 *** www.dieseyer.de *******************************
'
' Datei: DateiZeilenweiseLesenBearbeitenSchreiben.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Eine (ASCII_) Datei wird zeilenweise in ein Array gelesen,
' das Array bearbeitet und in eine Datei ausgegegeben.
'
'************************************************************
Option Explicit
Dim FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oArgs : 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 ) ' Datei zum Lesen öffnen
i = 0 : ReDim Preserve Zeile(i)
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = UBound( Zeile ) + 1 : ReDim Preserve Zeile(i) : Zeile(i) = FileIn.Readline
Loop
If UBound( Zeile ) < 1 Then
i = UBound( Zeile ) : 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 = LBound( Zeile ) 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
'*********************************************************
#########################################################################
>>> 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
#########################################################################
>>> dhcpenable.vbs <<<
'-----------------------------------------------------------------------
' The following script reads the registry value name IPAddress to
' determine which registry entries need to be changed to enable DHCP.
' This sample checks the first 11 network bindings for TCP/IP, which is
' typically sufficient in most environments.
' ----------------------------------------------------------------------
' from http://support.microsoft.com/default.aspx?scid=kb;EN-US;q197424
Dim WSHShell, NList, N, IPAddress, IPMask, IPValue, RegLoc
Set WSHShell = WScript.CreateObject("WScript.Shell")
NList = array("0000","0001","0002","0003","0004","0005","0006", "0007","0008","0009","0010")
On Error Resume Next
RegLoc = "HKLM\System\CurrentControlSet\Services\Class\NetTrans\"
For Each N In NList
IPValue = "" 'Resets variable
IPAddress = RegLoc & N & "\IPAddress"
IPMask = RegLoc & N & "\IPMask"
IPValue = WSHShell.RegRead(IPAddress)
If (IPValue <> "") and (IPValue <> "0.0.0.0") then
WSHShell.RegWrite IPAddress,"0.0.0.0"
WSHShell.RegWrite IPMASK,"0.0.0.0"
end If
Next
WScript.Quit ' Tells the script to stop and exit.
#########################################################################
>>> 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#########################################################################
>>> diranalyze.vbs <<<
'v4.7*****************************************************
' File: DirAnalyze.vbs
' Autor: Mueller@tensor.de
' www.tensor.de
'
' Findet verdächtig lange Verzeichnisnamen im Dateisystem
' und speichert sie in einer Logdatei.
'
' Muss mit administrativen Rechten ausgeführt werden!!!
' Wenn der Administrator nicht überall zumindest Lesesrechte
' hat, meldet das Programm für das erste zutreffende Verzeichnis
' einen Fehler und bricht die Verarbeitung ab
'*********************************************************
Option Explicit
Dim WSHShell, fso, oArgs
Dim Pfad, j, MaxNameLen,k, i
Dim StartVerz, Limit
Dim FoundMinus1, Longest
Dim Fileout, fsolog
Dim Drives(30)
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set oArgs = Wscript.Arguments
If oArgs.Count <> 2 Then
Wscript.Echo "Aufruf: <Zu untersuchendes Laufwerk; alternativ 'ALL' oder LOCAL> <Limitlänge> (als Zahl>100)"
WScript.Echo "Beispiel: Diranalyze ALL 180"
WScript.Echo "--> Die gesamte Laufwerksliste wird auf Verzeichnisnamen länger als 180 Zeichen analysiert"
Wscript.Quit 1
End If
If not isnumeric(oArgs(1)) then
Wscript.Echo "Ihr zweiter Aufrufparameter ist nicht numerisch."
Wscript.Quit 1
end if
If oArgs(1) < 100 then
Wscript.Echo "Der Parameter 'Maximale Länge' ist zu klein gewählt."
Wscript.Quit 1
end if
limit = cint(oArgs(1))
ClearLogDatei
FoundMinus1=" "
j=0
MaxNameLen=0
For i=0 To 30
Drives(i)= " "
Next
EvaluateLWs
IF NOT fso.FolderExists(Drives(0) & "\") Then
'hier verlassen wir uns drauf, das EvaluateLWs exakt arbeitet
WScript.Echo Drives(0) & " ist kein gültiges Laufwerk."
WScript.Quit 1
End If
i=0
Do While Drives(i) <> " "
Set Startverz = fso.GetFolder(Drives(i) & "\" )
DirsRecursive Startverz
i= i + 1
Loop
Logdatei(vbCrLf & "Maximal gefundene Namenslänge: " & MaxNameLen & " und zwar in:")
Logdatei(Longest)
CloseLogDatei
wscript.echo "Fertig, " & j & " Verzeichnisnamen mit mehr als " & limit & " Zeichen Länge gefunden."
If MaxNameLen > 220 Then wscript.Echo "Es gibt kritisch lange Dateinamen mit mehr als 220 Zeichen - sichten Sie die Logdatei!"
Sub DirsRecursive (Startpfad)
Dim MySubFolders
Dim MyFolder
Dim NameLen
If UCase(Startpfad)=Drives(i) & "\SYSTEM VOLUME INFORMATION" Then Exit sub
Set MySubFolders = Startpfad.SubFolders
'Vorbereitung Rekursiver Aufruf, Unterverzeichnisse zuerst.
On Error Resume Next
k = MySubFolders.Count
If Not err.number = 0 Then
Select Case err.number
Case 70
logdatei("Berechtigungsproblem im Ordner " & Startpfad)
wscript.Echo "Kann die Datenmenge nicht verarbeiten, solange Sie nicht über die notwendigen Berechtigungen verfügen."
wscript.Echo "Fehler trat im Pfad " & Startpfad & " auf. Übernehmen Sie ggf. Besitz über das Laufwerk und erteilen Sie sich dann zumindest Leserechte!"
Case 76
logdatei("Ordnername zu lang und zwar in " & Startpfad)
wscript.Echo "Kann die Datenmenge nicht verarbeiten, solange kritisch lange Ordnernamen auftreten."
wscript.Echo "Fehler trat im Pfad " & Startpfad & " auf. Kürzen Sie die Namen, indem Sie die Struktur nach oben VERSCHIEBEN!"
End Select
Logdatei(vbCrLf & "Bis hierher gefundene maximale Namenslänge: " & MaxNameLen & " und zwar in:")
Logdatei(Longest)
CloseLogDatei
wscript.Quit
End If
On Error GoTo 0
If k <> 0 Then
For each MyFolder in MySubFolders
DirsRecursive MyFolder
namelen=len (MyFolder.path)
if NameLen>MaxNameLen then
MaxNameLen=NameLen
Longest = MyFolder.path
end if
if namelen > limit then
'Pfadnamen, die länger als limit Zeichen sind, werden sofort in die Logdatei geschrieben -->
'der erste Pfadname, der das Kriterium erfüllt ist, bedingt durch den rekursiven Aufruf, der innerste auflösbare
'der nächste Pfadname könnte immer noch länger als limit Zeichen sein, obwohl er übergeordnete des vorhergehenden ist -->
'der interessiert aber nicht mehr --> daher dieser instr- Vergleich. Und besonders schön: Durch Rekursion
'tauchen übergeordnete zu lange immer als Nachfolger des schon gefundenen auf. NUR DESHALB ist Vergleich statthaft.
if instr (1, FoundMinus1 , MyFolder.path,1) = 0 then
FoundMinus1=MyFolder.path
'Letzten gefundenen speichern
If namelen>220 Then LogDatei("KRITISCH: "& MyFolder.path) Else LogDatei(MyFolder.path)
j=j+1
if j>=1000 then
LogDatei("Zu viele Treffer - zu unscharfe Parameter oder sehr viele Probleme mit zu langen Namen.")
Wscript.echo("Programm beendet - zu viele Treffer")
wscript.quit
end if
end if
end if
Next
End If
End Sub
'------------------------------------------------------------------------------------------
'End of DirsRecursive
'------------------------------------------------------------------------------------------
Sub LogDatei (LogTxt)
fileOut.WriteLine (LogTxt)
End Sub ' LogDatei
' **************************************************************
' **************************************************************
Sub ClearLogDatei
' **************************************************************
Set fsolog = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( fsolog.GetBaseName( WScript.ScriptName ) & ".log", 2, true)
End Sub ' ClearLogDatei
' **************************************************************
' **************************************************************
Sub CloseLogDatei
' **************************************************************
Fileout.Close
Set FileOut = Nothing
End Sub ' CloseLogDatei
' **************************************************************
sub EvaluateLWs
Dim fso, d, dc, i
Set fso = CreateObject("Scripting.FileSystemObject")
Set dc = fso.Drives
i=0
If InStr(1,oArgs(0),":",1) Then
Drives(0) = oArgs(0)
Exit Sub
End if
For Each d in dc
' Case 0: t = "Unbekannt"
' Case 1: t = "Austauschbar"
' Case 2: t = "Fest"
' Case 3: t = "Netzwerk"
' Case 4: t = "CD-ROM"
' Case 5: t = "RAM-Laufwerk"
If d.Drivetype=2 Then
Drives(i)=D.Driveletter & ":"
i = i + 1
End If
If d.Drivetype=3 Then
If ucase(oArgs(0)) = "ALL" Then
Drives(i)=D.Driveletter & ":"
i = i + 1
End If
End If
Next
End Sub
#########################################################################
>>> disk0-test.vbs <<<
'v7.2*****************************************************
' File: disk0-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt Infos zu Laufwerk C:, die von DISKPART.EXE stammen.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Txt, Tst, i
Dim oExec
Const HDD = "DISK 0"
' Größe der HDD ermitteln
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set oExec = WSHShell.Exec( "diskpart.exe" )
Do While Not oExec.StdOut.AtEndOfStream
WScript.Sleep 15
Txt = oExec.StdOut.ReadLine
Tst = Tst & Txt & vbCRLF
' MsgBox Txt & vbCRLF & vbCRLF & Tst, , "0029 :: " ' zeigt in der ersten Zeile die letzte Ausgabe
If InStr( UCase( Txt ), "COMPUTER" ) > 0 Then oExec.StdIn.Write "list disk" & vbCRLF
If InStr( UCase( Txt ), "GB " ) > 0 Then oExec.StdIn.Write "exit" & vbCRLF : Exit Do
WScript.Sleep 15
Loop
oExec.Terminate
Set oExec = nothing
MsgBox Tst, , "0039 :: " ' Anwendung ist beendet
Tst = Split(Txt, " ", -1)
For i = LBound( Tst ) to UBound( Tst )
If InStr( Tst(i), "GB" ) Then Txt = Tst(i-1) ' Größe der HDD in GB
Next
Txt = "Laufwerk C: ist " & Txt & " GB groß."
WSHShell.Popup Txt ,30 , "0048 :: " & WScript.ScriptName, 4096 + 256
WScript.Quit
#########################################################################
>>> 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 ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 ) ' 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 ) ' 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 ) ' 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
#########################################################################
>>> dnstesten.vbs <<<
'*** v10.5 *** www.dieseyer.de *****************************
'
' Datei: AAAAA.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Liest das Verbindungsspez. DNS-Suffix, der normalerweise
' per DHCP auf dem Client gesetzt wird.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox "Verbindungsspez. DNS-Suffix: " & DNSTesten( "." ), vbInformation, WScript.ScriptName
WScript.Quit
'*** v10.5 *** www.dieseyer.de *****************************
Function DNSTesten( PC )
'***********************************************************
' Liest das Verbindungsspez. DNS-Suffix, der normalerweise
' per DHCP auf dem Client gesetzt wird.
Dim objWMIService, colAdapters, objAdapter
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colAdapters = objWMIService.ExecQuery ("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
For Each objAdapter in colAdapters
If IsNull( objAdapter.DNSDomain ) = 0 Then DNSTesten = objAdapter.DNSDomain : Exit For
Next
End Function ' DNSTesten( PC )
#########################################################################
>>> druckerauswahl.vbs <<<
'v3.C***********************************************************
' 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)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
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 <<<
'v4.7********************************************************
' File: DruckerListe.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle Drucker, die am Computer definiert sind
'************************************************************
Option Explicit
Dim n, i, Text, TextX
Dim WSHShell, WSHNet, NetPRN, fso
Dim ObjReg, ObjRemote, KeyX, Rootkey, oVal
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
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
Set ObjRemote = objReg.RemoteRegistry(wshnet.ComputerName) ' Objekt zeigt auf aktuellen PC (REGOBJ.DLL)
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion"
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows"
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
if oVal.Name = "Device" then TextX = oVal.Value & "Device"
Next
On Error GoTo 0
Text = ""
For i = 0 To NetPRN.Count-1 Step 2
Text = Text & vbCRLF & vbTab & "Dr." & (i+2)/2 & vbTab & NetPRN(i) & vbTab & NetPRN(i+1)
If InStr( TextX, NetPRN(i) ) then Text = Text & vbCRLF & "==>" & vbTab & "Dr." & (i+2)/2 & " ist der Standarddrucker."
Next
MsgBox Text, , WScript.ScriptName
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
WScript.Quit
#########################################################################
>>> emailausad.vbs <<<
'*** v?.? *** www.dieseyer.de ******************************
'
' Datei: emailausad.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ermittel zu einem AD-Objekt (User) die hinterlegte
' Email-Adr.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim User, Tst
User = "dsey-er"
Tst = EmailAdrAusUserID( User )
MsgBox Tst, , "22 :: "
WScript.Quit
'*** v10.9 *** www.dieseyer.de *****************************
Function EmailAdrAusUserID( UserID )
'***********************************************************
' http://gallery.technet.microsoft.com/ScriptCenter/en-us/2809b510-5589-4764-9966-c69d20144bdf
Const xLDAP = "LDAP://DC=emea,DC=corpdir,DC=net"
Dim cnn : Set cnn = CreateObject("ADODB.Connection")
Dim sqlCMD : Set sqlCMD = CreateObject("ADODB.Command")
cnn.Provider = "ADsDSOObject"
' AccessUser = "[DOMAIN]\[USERNAME]"
' AccessPwd = "[PASSWORD]"
' cnn.Open "Active Directory Provider" ', AccessUser, AccessPwd
cnn.Open "Active Directory Provider"
sqlCMD.ActiveConnection = cnn
sqlCMD.CommandText = "SELECT Name, Mail FROM '" & xLDAP & "' WHERE objectClass='User' AND samAccountName='" & UserID & "'"
Dim rs : Set rs = sqlCMD.Execute
On Error Resume Next
EmailAdrAusUserID = rs.Fields("Mail").Value
End Function ' EmailAdrAusUserID( UserID )
#########################################################################
>>> emailsenden.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
'
' Datei: emailsenden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt
' ...Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim EmailTo : EmailTo = "nichtverwendet@gmx.de"
Dim EmailFrom : EmailFrom = EmailTo
Dim UserName : UserName = EmailTo
Dim UserPwd : UserPwd = "PwdIstGeheim!"
Dim SMTPServer : SMTPServer = "smtp.1und1.de"
: SMTPServer = "mail.gmx.net"
Dim Betreff : Betreff = "Email per SMTP mit Login"
Dim Text : Text = "Ich hoffe, das VBS packt das . . . von " & CreateObject("WScript.Network").ComputerName
Dim Anhang : Anhang = WScript.ScriptFullName ' als Anhang dieses VBS
: Anhang = "" ' kein Anhang'
EmailSenden SMTPServer, EmailFrom, EmailTo, UserName, UserPwd, Betreff, Text, Anhang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Popup "EMail versendet an " & vbCRLF & vbCRLF & vbTab & EmailTo, 7, "31 :: " & WScript.ScriptName, vbInformation
WScript.Quit
'*** v9.A *** www.dieseyer.de ******************************
Sub EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'***********************************************************
' Siehe http://www.microsoft.com/technet/scriptcenter/guide/sas_ent_wbpa.mspx?mfr=true
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt:
' .Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
' Sonst kommt:
' 550 must be authenticated
' 550 Need to authenticate
' Siehe http://msdn.microsoft.com/en-us/library/ms526318%28EXCHG.10%29.aspx
Dim Tst
Dim objEmail : Set objEmail = CreateObject("CDO.Message")
objEmail.From = EmailVon
objEmail.To = EmailAn
' objEmail.Cc = EmailAn
' objEmail.Bcc = EmailAn
objEmail.Subject = Betreff
objEmail.Textbody = Text
If not Anhang = "" Then
objEmail.AddAttachment Anhang
End If
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = AnmName
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = AnmPassw
objEmail.Configuration.Fields.Update
On Error Resume Next
Tst = objEmail.Send
If err.Number <> 0 Then MsgBox err.Number & " - " & err.Description, , "70 :: " & WScript.ScriptName
End Sub ' EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
#########################################################################
>>> emailsenden_cmd.vbs <<<
'*** v10.B *** www.dieseyer.de *****************************
'
' Datei: emailsenden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt
' ...Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim EmailTo : EmailTo = "nichtverwendet@gmx.de"
Dim EmailFrom : EmailFrom = EmailTo
Dim UserName : UserName = EmailTo
Dim UserPwd : UserPwd = "PwdIstGeheim!"
Dim SMTPServer : SMTPServer = "smtp.1und1.de"
: SMTPServer = "mail.gmx.net"
Dim Betreff : Betreff = WScript.CreateObject("WScript.Network").ComputerName
Dim Text : Text = ""
Dim Anhang : Anhang = "" ' kein Anhang'
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = LogDateiFestlegenX64() ' Prozedur-Aufruf
Trace32Log "037 :: ", 1
Trace32Log "038 :: Start " & WScript.ScriptFullName & " ( Dateidatum: " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "039 :: LogDatei: " & LogDatei, 1
Trace32Log "040 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "041 :: Angemeldeter User: " & WSHNet.UserName, 1
For i = 0 to Args.Count - 1 ' hole alle Argumente
Text = Text & " " & Trim( Args( i ) )
Next
Trace32Log "046 :: Erhaltenes Argument: '" & Text & "'", 1
EmailSenden SMTPServer, EmailFrom, EmailTo, UserName, UserPwd, Betreff, Text, Anhang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Popup "EMail versendet an " & vbCRLF & vbCRLF & vbTab & EmailTo, 7, "051 :: " & WScript.ScriptName, vbInformation
WScript.Quit
'*** v9.A *** www.dieseyer.de ******************************
Sub EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'***********************************************************
' Siehe http://www.microsoft.com/technet/scriptcenter/guide/sas_ent_wbpa.mspx?mfr=true
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt:
' .Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
' Sonst kommt:
' 550 must be authenticated
' 550 Need to authenticate
' Siehe http://msdn.microsoft.com/en-us/library/ms526318%28EXCHG.10%29.aspx
Dim Tst
Dim objEmail : Set objEmail = CreateObject("CDO.Message")
objEmail.From = EmailVon
objEmail.To = EmailAn
' objEmail.Cc = EmailAn
' objEmail.Bcc = EmailAn
objEmail.Subject = Betreff
objEmail.Textbody = Text
If not Anhang = "" Then
objEmail.AddAttachment Anhang
End If
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = AnmName
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = AnmPassw
objEmail.Configuration.Fields.Update
On Error Resume Next
Tst = objEmail.Send
If err.Number <> 0 Then MsgBox err.Number & " - " & err.Description, , "090 :: " & WScript.ScriptName
End Sub ' EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'************************************************************
Function LogDateiFestlegenX64()
'************************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = WScript.FullName ' ergibt C:\WINDOWS\system32\wscript.exe
Txt = Mid( Txt, 1, InStrRev( Txt, "\" ) - 1 ) ' ergibt C:\WINDOWS\system32
Tst = Mid( Txt, 1, InStrRev( Txt, "\" ) - 1 ) & "\SysWOW64" ' ergibt C:\WINDOWS\SysWOW64
If fso.FolderExists( Tst ) Then Txt = Tst ' : MsgBox Txt & vbCRLF & Tst, , "106 :: "
Txt = Txt & "\CCM" ' ergibt C:\WINDOWS\sysWOW64\CCM\ oder C:\WINDOWS\system32\CCM\
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
Txt = Txt & "\Inst.Log" ' ergibt C:\WINDOWS\sysWOW64\CCM\Inst.Log\ oder C:\WINDOWS\system32\CCM\Inst.Log\
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
Txt = Txt & "\" & WScript.ScriptName ' ergibt ..\CCM\Inst.Log\....vbs"
Txt = Mid( Txt, 1, InStrRev( Txt, "." ) ) ' ergibt ..\CCM\Inst.Log\...."
Txt = Txt & "log" ' ergibt ..\CCM\Inst.Log\....log"
LogDateiFestlegenX64 = Txt
End Function ' LogDateiFestlegenX64()
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "203 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "204 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> erinnerung.vbs <<<
'v4.A*****************************************************
' File: erinnerung.vbs
' Autor: Zuujin@web.de
' http://source-center.de/forum/member.php?u=1294
'
' http://dieseyer.de
'
' Erstellt mit Datum/Zeit eine versteckte "C:\Erinnerung.txt"
' und setzt in der Egistry "/All Users/.../Autostart/" einen
' Eintrag, damits beim nächsten systemstart das Skript
' (versteckt) wieder anläuft (und die .txt ausliest) . . .
' bis die Zeit REIF ist
'*********************************************************
set fso = CreateObject ("scripting.filesystemobject")
set sho = CreateObject ("wscript.shell")
Wert = False
IF NOT fso.FileExists ("C:\Erinnerung.txt") THEN
Heute = msgbox ("Würde die Erinnerung am heutigen Tag stattfinden?",vbyesno or vbquestion,"Erinnerung heute?")
IF Heute = vbyes THEN
input = inputbox ("Bitte geben sie die Uhrzeit ein, zu der sie erinnert werden möchten:"&vbcr &" Schema: HH:MM:SS","Wann?",Time)
IF IsEmpty (input) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
MsgInput = inputbox ("An was wollen sie erinnert werden?","Was?")
IF IsEmpty (MsgInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
msgbox "Erinnerung gesetzt!",vbinformation,"Timer gestartet!"
DO
Zeit = time
input = CDate (input)
IF Zeit > input THEN
msgbox MsgInput,vbexclamation,"Erinnerung!"
Wert = True
END IF
wscript.sleep 500
LOOP UNTIL Wert = True
END IF
END IF
' ==============
' = MIT DATUM =
' ==============
ELSE
DateInput = inputbox ("Bitte geben sie das Datum ein, zu dem sie erinnert werden möchten:"&vbcr &" Schema: DD.MM.JJJJ","Wann?",Date)
IF IsEmpty (DateInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
TimeInput = inputbox ("Bitte geben sie die Uhrzeit ein, zu der sie erinnert werden möchten:"&vbcr &" Schema: HH:MM:SS","Wann?",Time)
IF IsEmpty (TimeInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
MsgInput = inputbox ("An was wollen sie erinnert werden?","Was?")
IF IsEmpty (MsgInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
Set File = fso.CreateTextFile ("C:\Erinnerung.txt")
File.writeline (DateInput)
File.writeline (TimeInput)
File.writeline (MsgInput)
File.close
Set RemFile = fso.getfile ("C:\Erinnerung.txt")
RemFile.attributes = RemFile.Attributes +2
Scriptpath = WScript.ScriptFullname
Set Script = fso.GetFile (Scriptpath)
Script.copy ("C:\Dokumente und Einstellungen\All Users\Startmenü\Programme\Autostart\Erinnerung.vbs ")
msgbox "Erinnerung gesetzt!",vbinformation,"Timer gestartet!"
DO
Jetzt = now
input = DateInput &" " &TimeInput
input = CDate (input)
IF Jetzt > input THEN
msgbox MsgInput,vbexclamation,"Erinnerung!"
Wert = True
RemFile.delete
END IF
wscript.sleep 500
LOOP UNTIL Wert = True
END IF
END IF
END IF
END IF
'================
'= NACH NEUSTART =
'================
ELSE
Const ForReading = 1
Set TXTFile = fso.OpenTextFile ("C:\Erinnerung.txt", ForReading)
DateInput = TXTFile.readline
TimeInput = TXTFile.readline
MsgInput = TXTFile.readline
TXTFile.close
DO
Jetzt = now
input = DateInput &" " &TimeInput
input = CDate (input)
IF Jetzt > input THEN
msgbox MsgInput,vbexclamation,"Erinnerung!"
Wert = True
Set RemFile = fso.getfile ("C:\Erinnerung.txt")
Set Script = fso.getfile ("C:\Dokumente und Einstellungen\All Users\Startmenü\Programme\Autostart\Erinnerung.vbs ")
RemFile.delete
Script.delete
END IF
wscript.sleep 500
LOOP UNTIL Wert = True
END IF
#########################################################################
>>> eventlog-bluescreen.vbs <<<
'v4.5*****************************************************
' File: eventlog-bluescreen.vbs
' (aus DateiZeilenweiseLesenBearbeitenSchreiben.vbs )
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' BlueScreens stehen nicht im Eventlog. Um zu sehen, wie oft
' es mögicherweise eine gegeben hat, kann man auswerten, wie
' oft die EventID 6006 (Shutdown) fehlt.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Txt, i, 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 das Skript beendet
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then
MsgBox "Datei auf das Skript ziehen und fallen lassen." & vbCRLF & vbCRLF & vbTab & " Das ist das Ende", , WScript.ScriptName
WScript.Quit
End If
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
Datei = fso.GetParentFolderName( WScript.ScriptFullName ) & "\" & fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' alle Zeilen lesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i= 1
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
Txt = FileIn.ReadLine
Txt = Replace( Txt, ".04 " , ".04 " )
Txt = Replace( Txt, " EventLog Informationen --- " , " " )
Txt = Replace( Txt, " --- " , " " )
If Instr( Txt, "6005") Then FileOut.WriteLine( "+ " & Txt & vbTab & i ) : i = i + 1
If Instr( Txt, "6006") Then FileOut.WriteLine( "- " & Txt )
' If Instr( Txt, "6009") Then FileOut.WriteLine( Txt )
Loop
FileIn.Close
Set FileIn = nothing
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 )
#########################################################################
>>> eventlog.vbs <<<
'*** v9.9 *** www.dieseyer.de ******************************
'
' Datei: eventlog.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Den Abarbeitungsstatus eines Skripts kann man mit einem
' Einzeiler oder mit der Prozedur 'AnwendungEreignisInEventLog'
' in die Ereignisanzeige (Eventlog) Anwendungen (Application)
' schreiben.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst
Tst = WSCript.ScriptName & " wurde gestartet . . . "
AnwendungEreignisInEventLog 0, Tst
WScript.Sleep 2*1000
WScript.CreateObject("WScript.Shell").LogEvent 2, "Das geht auch in einer Zeile!"
Tst = WSCript.ScriptName & " wird jetzt beendet."
AnwendungEreignisInEventLog 4, Tst
WScript.Quit
'*** v9.9 *** www.dieseyer.de ******************************
Sub AnwendungEreignisInEventLog( EventType, Txt )
'***********************************************************
' Mögliche Werte für den EventType:
' 0 SUCCESS
' 1 ERROR
' 2 WARNING
' 4 INFORMATION
' 8 AUDIT_SUCCESS
' 16 AUDIT_FAILURE
WScript.CreateObject("WScript.Shell").LogEvent EventType, Txt
End Sub ' AnwendungEreignisInEventLog( EventType, Txt )
#########################################################################
>>> exec-hidden-plus.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' 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 ipconfig /all" ), , "20 :: " & WScript.ScriptName
MsgBox ExecHiddenPlus ( "%comspec% /c Ping 127.0.0.1 -n 1" ), , "21 :: " & WScript.ScriptName
WScript.Quit
'*** v9.4 *** www.dieseyer.de ******************************
Function ExecHiddenPlus( CMD )
'***********************************************************
Dim FileOut, oWsh, Tmp
Tmp = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
If CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
CreateObject("Scripting.FileSystemObject").DeleteFile Tmp, True
End If
If not CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
' zum Test nächste Zeile frei geben
' MsgBox Tmp & vbCRLF & vbCRLF & "F E H L T und wird deshalb neu geschrieben.", , "40 :: " & Titel
Set FileOut = CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = """" " )
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"" )( ""Ergebnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ), , WScript.ScriptName & "" Ende "" " )
FileOut.Close
Set FileOuT = nothing
End If
Set oWsh = CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp & " " & CMD , 0, true
ExecHiddenPlus = oWsh.Environment("Volatile")( "Ergebnis" )
' zum Test nächste Zeile frei geben - Löschen der 'Tmp-Datei
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHiddenPlus( CMD )
#########################################################################
>>> 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 )
' **************************************************************
#########################################################################
>>> formatbytes.vbs <<<
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim m, t, x, i, k
m = 1
t = x = x : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1025 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
' MsgBox x
x = "" : m = 3 : t = 390 : i = 1.5
Do
i = i * 1.01
t = t * i
k = t
k = FormatNumber( k, 0,0,0, -1)
x = x & FormatkMGTBytes( k, m ) & " " & vbTab & FormatNumber( t, 0,0,0, -1) & vbCRLF
If t > 1024*1024*1024*1024*64 Then Exit Do
Loop
MsgBox x, 4096, t
WScript.Quit
'***********************************************************
Function FormatkMGTBytes( n, i )
'***********************************************************
Dim Tyt
' if i > 1 Then i = i - 1
Tyt = " Byte"
If n > 10 Then Tyt = " Byte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " Byte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " kByte" : n = FormatNumber( n / 1024, i )
If n > 10 Then Tyt = " kByte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " kByte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " MByte" : n = FormatNumber( n / 1024, i )
If n > 10 Then Tyt = " MByte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " MByte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " GByte" : n = FormatNumber( n / 1024, i )
If n > 10 Then Tyt = " GByte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " GByte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " TByte" : n = FormatNumber( n / 1024, i )
FormatkMGTBytes = n & Tyt
End Function ' FormatkMGTBytes( n, i )
#########################################################################
>>> 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
#########################################################################
>>> gmxautologin2009.vbs <<<
'*** v9.B *** www.dieseyer.de ******************************
' File: GmxAutologin2009.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
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
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
WScript.Sleep 33
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Const READYSTATE_COMPLETE = 4
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
WScript.Sleep 33
Loop
Set oDoc = MeinIE.Document ' 2009
oDoc.all.username.value = Kennung
oDoc.all.password.value = Passwort
oDoc.all.inpLoginSubmit.value = "login"
oDoc.all.formLogin.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
WScript.Quit
' 2009 - zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' => <form id="formLogin" action="//service.gmx.net/de/cgi/login" method="post" name="login">
'
' <input name="AREA" value="1" type="hidden"/>
' <input name="EXT" value="redirect" type="hidden"/>
' <input name="EXT2" value="" type="hidden"/>
' <input name="uinguserid" value="" type="hidden"/>
' <fieldset id="fieldsetLoginUser">
' <label for="username"><span>E-Mail:</span></label>
' => <input name="id" id="username" class="field" type="text" value=""/>
' <label for="password"><span>Passwort:</span></label>
'
' => <input name="p" id="password" class="field" type="password" value=""/>
' <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' </fieldset>
' </form>
' IE2003: <input type="text" name="id" size="10" class="i10">
' IE2009: <input name="id" id="username" class="field" type="text" value=""/>
' VBS2003: oDoc.all.id.value = Kennung
' VBS2009: oDoc.all.username.value = Kennung
' Funktion: Das VBS trägt den Anmeldenamen ein: Das auszufüllende Feld (type="text")
' wird durch die ID (id="username") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Kennung' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Kennung
' IE2003: <input type="password" name="p" size="10" class="i10">
' IE2009: <input name="p" id="password" class="field" type="password" value=""/>
' VBS2003: oDoc.all.p.value
' VBS2009: oDoc.all.password.value
' Funktion: Das VBS trägt das Passwort ein: Das auszufüllende Feld (type="password")
' wird durch die ID (id="password") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Passwort' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Passwort
' IE2009: <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' VBS2003: oDoc.all.login.Submit
' VBS2009: oDoc.all.formLogin.Submit
' Funktion: Das VBS 'drückt' den [login]-Button: Anders als zunächst anzunehmen, muss
' NICHT <input> mit id="inpLoginSubmit" betätigt werden (Submit), sondern
' das Formular <form id="formLogin">: '
' oDoc.all.formLogin.Submit
#########################################################################
>>> gmxautologin2010.vbs <<<
'*** v10.1 *** www.dieseyer.de ******************************
' File: GmxAutologin2010.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
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
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
WScript.Sleep 33
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Const READYSTATE_COMPLETE = 4
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
WScript.Sleep 33
Loop
Set oDoc = MeinIE.Document ' 2010
oDoc.all.inpLoginFreemailUsername.value = Kennung
oDoc.all.inpLoginFreemailPassword.value = Passwort
oDoc.all.formLoginFreemail.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
WScript.Quit
' 2010 - zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' => <form id="formLoginFreemail" class="login" action="https://service.gmx.net/de/cgi/login" method="post">
' <fieldset>
' <legend>Login</legend>
' <input type="hidden" name="AREA" value="1"/>
' <input type="hidden" name="EXT" value="redirect"/>
' <input type="hidden" name="EXT2" value=""/>
' <input type="hidden" name="uinguserid" value="__uuid__"/>
' <input type="hidden" name="dlevel" value="c"/>
' <input type="text" class="field username" id="inpLoginFreemailUsername" name="id" value=""/>
' => <input type="password" class="field password" id="inpLoginFreemailPassword" name="p" value=""/>
' => <input type="submit" class="submit" value="Login"/>
' <ul>
' <li class="first"><a href="http://service.gmx.net/de/cgi/g.fcgi/login/lose/password">Passwort vergessen?</a></li>
' <li class="last"><a href="http://www.gmx.net/nossl/">Ohne SSL</a></li>
' </ul>
' </fieldset>
' </form>
' 2009 - zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' => <form id="formLogin" action="//service.gmx.net/de/cgi/login" method="post" name="login">
'
' <input name="AREA" value="1" type="hidden"/>
' <input name="EXT" value="redirect" type="hidden"/>
' <input name="EXT2" value="" type="hidden"/>
' <input name="uinguserid" value="" type="hidden"/>
' <fieldset id="fieldsetLoginUser">
' <label for="username"><span>E-Mail:</span></label>
' => <input name="id" id="username" class="field" type="text" value=""/>
' <label for="password"><span>Passwort:</span></label>
'
' => <input name="p" id="password" class="field" type="password" value=""/>
' <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' </fieldset>
' </form>
' IE2003: <input type="text" name="id" size="10" class="i10">
' IE2009: <input name="id" id="username" class="field" type="text" value=""/>
' VBS2003: oDoc.all.id.value = Kennung
' VBS2009: oDoc.all.username.value = Kennung
' Funktion: Das VBS trägt den Anmeldenamen ein: Das auszufüllende Feld (type="text")
' wird durch die ID (id="username") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Kennung' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Kennung
' IE2003: <input type="password" name="p" size="10" class="i10">
' IE2009: <input name="p" id="password" class="field" type="password" value=""/>
' VBS2003: oDoc.all.p.value
' VBS2009: oDoc.all.password.value
' Funktion: Das VBS trägt das Passwort ein: Das auszufüllende Feld (type="password")
' wird durch die ID (id="password") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Passwort' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Passwort
' IE2009: <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' VBS2003: oDoc.all.login.Submit
' VBS2009: oDoc.all.formLogin.Submit
' Funktion: Das VBS 'drückt' den [login]-Button: Anders als zunächst anzunehmen, muss
' NICHT <input> mit id="inpLoginSubmit" betätigt werden (Submit), sondern
' das Formular <form id="formLogin">: '
' oDoc.all.formLogin.Submit
#########################################################################
>>> 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 <<<
'v4.9********************************************************
' 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"
Daten = "C:\daten.tst"
Daten = "D:\TOOLS"
ZielVerz = "c:\1-tst-"
ZielVerz = "d:\1-tst-"
ZielVerz = "c:\1-tst-"
ZielLw = ""
ZielLw = "V:" ' bei RAM-Disk = V:
ZielLw = ""
MaxTst = 999
LaufWerk = fso.GetDriveName( ZielVerz )
Text = " "
'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
' Das Daten-Verzeichnis bis zum Überquellen füllen, wenn es sich auf der RAM-Disk befindet
Text = ""
If not fso.FolderExists( Left(ZielLw, 2) & Mid(Daten, 3) ) then
Text = " "
ShellFolderCopy Daten, Left(ZielLw, 2) & Mid(Daten, 3)
If not Text = "" Then
MsgBox "Fehler beim Füllen des Daten-Verzeichnis!" & vbCRLF & vbCRLF & Text & vbCRLF & vbCRLF & ". . . das ist das Ende!", , WScript.ScriptName
WScript.Quit
End If
End If
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)
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))
Zeit = now()
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
If not Text = "" Then
MsgBox "Fehler/Abbruch beim Kopieren nach " & ZielVerz & "\" & Nr & " !" & vbCRLF & vbCRLF & Text & vbCRLF & vbCRLF & ". . . das ist das Ende!", , WScript.ScriptName
WScript.Quit
End If
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
On Error Resume Next
fso.CopyFolder Quelle, Ziel, True
if not err.Number = 0 Then Text = err.Number & ": " & err.Description
On Error GoTo 0
Else
if not fso.FolderExists( Ziel ) then fso.CreateFolder( Ziel )
Set ShellApp = CreateObject("Shell.Application")
Set oZielOrdner = ShellApp.NameSpace( Ziel )
On Error Resume Next
Text = ""
oZielOrdner.CopyHere Quelle , 16 'vOptions
if not err.Number = 0 Then Text = err.Number & ": " & err.Description
On Error GoTo 0
Set oZielOrdner = nothing
Set ShellApp = nothing
End If
End Sub ' ShellFolderCopy
#########################################################################
>>> hdd0-test.vbs <<<
'v5.A*****************************************************
' File: hdd0-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt Infos zu Laufwerk C:.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Txt, Tst, i
Dim oExec
Const HDD = "DISK 0"
' Größe der HDD ermitteln
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set oExec = WSHShell.Exec( "diskpart.exe" )
Do While Not oExec.StdOut.AtEndOfStream
WScript.Sleep 15
Txt = oExec.StdOut.ReadLine
Tst = Tst & Txt & vbCRLF
' MsgBox Txt & vbCRLF & vbCRLF & Tst, , "0029 :: " ' zeigt in der ersten Zeile die letzte Ausgabe
If InStr( UCase( Txt ), "COMPUTER" ) > 0 Then oExec.StdIn.Write "list disk" & vbCRLF
If InStr( UCase( Txt ), "GB " ) > 0 Then oExec.StdIn.Write "exit" & vbCRLF : Exit Do
WScript.Sleep 15
Loop
oExec.Terminate
Set oExec = nothing
MsgBox Tst, , "0039 :: " ' Anwendung ist beendet
Tst = Split(Txt, " ", -1)
For i = LBound( Tst ) to UBound( Tst )
If InStr( Tst(i), "GB" ) Then Txt = Tst(i-1) ' Größe der HDD in GB
Next
Txt = "Laufwerk C: ist " & Txt & " GB groß."
WSHShell.Popup Txt ,30 , "0048 :: " & WScript.ScriptName, 4096 + 256
WScript.Quit
#########################################################################
>>> hintergrundbild.vbs <<<
'v6.2*****************************************************
' File: hintergrundbild.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'
' Ändert das Hintergrundbild des Desktops.
' (http://www.microsoft.com/communities/newsgroups/en-us/default.aspx?dg=microsoft.public.de.german.scripting.wsh&tid=1f4be8a0-4876-4d10-9a3f-6544d603888d&p=1)
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const sWallPaper = "C:\test.bmp"
' update in registry
WScript.CreateObject("WScript.Shell").RegWrite "HKCU\Control Panel\Desktop\Wallpaper", sWallPaper
' let the system know about the change
CreateObject("WScript.Shell").Run "%windir%\System32\RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", 1, True
#########################################################################
>>> 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
#########################################################################
>>> html2txt.vbs <<<
'*** v8.2 *** www.dieseyer.de ****************************
'
' Datei: html2txt.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' http://www.source-center.de/forum/showthread.php?t=25764
'
' Speichert den Quelltext (ohne Bilder, ohne CSS) in einer
' Datei (die gestartet wird).
'
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WWWSite : WWWSite = "http://dieseyer.de/tip/all128/index.html"
Dim SpeichernIn : SpeichernIn = "C:\html2txt.htm"
SpeichernIn = "C:\html2txt.txt"
Call Html2Txt( WWWSite, SpeichernIn )
WScript.CreateObject ("WScript.Shell").Run SpeichernIn
WScript.Quit
'*** v8.2 *** www.dieseyer.de ****************************
Function Html2Txt( SiteHtml, ZielDatei )
'*********************************************************
' On Error Resume Next
Dim msieapp : Set msieapp = CreateObject("internetexplorer.application") 'InternetExplorer.Application erstellen
Dim Txt
Const READYSTATE_COMPLETE = 4
With msieapp
.Navigate (SiteHtml) 'Seite ansteurn
.Visible = False 'Nicht sichtbar machen
Do While .Busy
'warten bis der Ie geladen ist
WScript.Sleep 50
Loop
Do While .ReadyState <> READYSTATE_COMPLETE
'warten bis die site geladen ist
WScript.Sleep 50
Loop
Txt = .document.documentElement.outerHTML 'in die variable strHtml den Html src speichern
.Quit 'beenden
End With
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(ZielDatei, 2, True).write Txt
End Function ' Html2Txt( SiteHtml, ZielDatei )
#########################################################################
>>> htmldateispeichern.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: htmldateispeichern.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' getURL( url, un, pw )
' zieht den Quelltext einer (Html-) Internetseite.
'
' http://www.source-center.de/forum/showthread.php?t=41077
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim HtmlSeite, Txt
HtmlSeite = "http://www.source-center.de/forum/showthread.php?t=41077"
Txt = getURL( HtmlSeite, "", "" )
MsgBox Txt
HtmlSeite = "http://dieseyer.de/index.html"
Txt = getURL( HtmlSeite, "", "" )
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( WSCript.ScriptFullName & ".html", 2, true ).Write( Txt )
WScript.CreateObject("WScript.Shell").Run WScript.ScriptFullName & ".html"
WScript.Quit
'*** v8.4 *** www.dieseyer.de *******************************
Function getURL( url, un, pw )
'************************************************************
' http://www.source-center.de/forum/showthread.php?t=41077
' Parameter : URL, UserName, Password
getURL=""
Dim oHTTP : Set oHTTP = CreateObject("MSXML2.XMLHTTP")
Call oHTTP.Open( "GET", url, False, un, pw )
oHTTP.Send
getUrl=oHTTP.ResponseText
Set oHTTP = Nothing
End Function ' getURL( url, un, pw )
#########################################################################
>>> http-server-test.vbs <<<
'v5.A***************************************************
' File: http-server-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Testet ob eine (Fehler-) Seite NICHT geladen wird
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const Link = "http://dieseyer.de/dse-wsh-scr-.html"
Const SuchBegriff = "2005"
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim StartZeit : StartZeit = Now()
Dim i, Tst, Text
LogDatei ( vbCRLF & Now() & vbTab & " Start von " & WScript.ScriptFullName )
Do
Do
Tst = now()
' Jede volle Minute
If Second( Tst ) = 0 Then
Text = Text & vbCRLF & Now() & vbTab & Tst & vbTab & i & " " & "32 :: "
End If
' Jede volle 5 Minuten
If Mid( Minute( Tst ), 2 ) = "5" OR Minute( Tst ) = 5 Then
If Second( Tst ) < 2 Then Text = Text & vbCRLF & Now() & vbTab & Tst & vbTab & i & " " & "32 :: "
End If
' Jede volle 10 Minuten
If Mid( Minute( Tst ), 2 ) = "0" OR Minute( Tst ) = 0 Then
If Second( Tst ) = 0 Then Text = Text & vbCRLF & Now() & vbTab & Tst & vbTab & i & " " & "33 :: "
End If
if not fso.FileExists( WScript.ScriptFullName ) Then Exit Do
Exit Do
Loop
if not fso.FileExists( WScript.ScriptFullName ) Then Exit Do
If not Text = "" Then i = i + 1 : Tst = TestLink( Link, SuchBegriff ) : LogDatei ( Now() & vbTab & Tst )
WScript.Sleep 10 : If not Text = "" Then Text = "" : WScript.Sleep 1*1000
Loop
LogDatei ( vbCRLF & Now() & vbTab & " Ende von " & WScript.ScriptFullName )
MsgBox vbTab & "Seit " & StartZeit & " wurde " & vbCRLF & Link & vbCRLF & vbTab & i & " mal getestet . . . ", , WScript.ScriptName
' WScript.CreateObject( "WScript.Shell" ).Run "notepad " & WScript.ScriptFullName & ".log"
WScript.Quit
'************************************************************
Function TestLink( Link, Tst )
'************************************************************
Dim MeinIE, READYSTATE_COMPLETE
' Dim oDoc, oArea, oRng
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
WScript.Sleeep 50
Loop
MeinIE.Visible = False ' True
MeinIE.Navigate Link
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
WScript.Sleep 50
Loop
TestLink = MeinIE.document.body.innerText
If InStr( UCase( TestLink ), UCase( Tst ) ) > 0 Then
TestLink = "Seite ist aufrufbar."
Else
TestLink = "=> Seite ist nicht verfügbar."
End If
WScript.Sleep 500
MeinIE.Quit
End Function ' TestLink( Link )
' **************************************************************
Sub LogDatei (LogTxt) ' v3.9 - http://dieseyer.de
' **************************************************************
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(WScript.ScriptName & ".log", 8, true).WriteLine (LogTxt)
End Sub ' LogDatei (LogTxt) ' v3.9 - http://dieseyer.de
#########################################################################
>>> httpget.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
'
' Datei: httpget.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Skript wird als Beispiel das aktuelle Wetter (und weitere
' Daten) von 'http://www.webservicex.net/globalweather.asmx'
' für Berlin abgefragt, in einer XML-Datei gespeichert und
' angezeigt. Welche Abfragen vom Webservice angenommen werden
' erfährt man, wenn man dies WWW-Adr. im Browser eingibt.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim XMLDatei, Txt, Tst
Txt = "http://www.webservicex.net/globalweather.asmx/GetWeather?CityName=Stuttgart&CountryName=Germany"
Tst = HttpGet( Txt )
MsgBox Txt & vbCRLF & vbCRLF & vbTab & "ergab:" & vbCRLF & vbCRLF & Tst, , "21 :: " & WScript.ScriptName
XMLDatei = WScript.ScriptFullName & ".xml"
CreateObject("Scripting.FileSystemObject").OpenTextFile( XMLDatei , 2, True).Write Tst
WScript.Sleep 33
CreateObject("WScript.Shell").Run """" & XMLDatei & """", , False
WScript.Quit
'*** v9.A *** www.dieseyer.de ******************************
Function HttpGet( url )
'***********************************************************
' MsgBox url, , "34 :: "
Dim Tst, i
Dim httpRequest : Set httpRequest = CreateObject("Microsoft.XMLHTTP")
' httpRequest.setRequestHeader "Accept", "*/*"
' httpRequest.setRequestHeader "UserAgent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50215)"
' httpRequest.setRequestHeader "Timeout", 1000*60
' httpRequest.setRequestHeader "CWA-Ticket", 1 'this.authTicket
httpRequest.Open "GET", url, True
httpRequest.Send()
Tst = "" : i = 0
Do
Tst = Tst & i & ": " & vbTab & httpRequest.readyState & vbCRLF
If httpRequest.readyState = 4 Then Exit Do
i = i + 1 : If i > 300 Then Exit Do
WScript.Sleep 33
Loop
' MsgBox Tst , , "52 :: " & i
' MsgBox "httpRequest.Status: '" & httpRequest.Status & "'"
If httpRequest.Status = 200 Then
HttpGet = httpRequest.ResponseText
Else
HttpGet = "58 :: FEHLER - ENDE"
End If
Set httpRequest = nothing
End Function ' HttpGet( url )
#########################################################################
>>> icon.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' Datei: icon.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' In Hta kann ein Symbol (Icon) für das Hta definiert werden:
' ICON="dieseyer.ico"
' The ICON attribute in Hta can be set with
' ICON="dieseyer.ico"
' Die Prozedur IcoAusHexDaten() erstellt aus den im Hta
' hinterlegten Binärdaten eine Icon-Datei.
' Einfügen der Binärdaten eines Icons: Öffnen der Ico-Datei
' mit PSPad; die Anzeige erfolgt im HEX-Format. Mit
' [Strg-a][Strg-c] befindet sich die gesamte Datei im HEX-
' Format in der Zwischenablage. Diese Zeichenkette wird hier
' im Beispiel der Variable Tst zugewiesen. Beim Aufruf von
' IcoAusHexDaten( ZielDatei, Txt )
' werden die Zeichen in die Icon-Datei geschrieben.
'
' Aus einer 4KByte Ico-Datei wird eine 8KByte Zeichenkette!
'
' The procedure IcoAusHexDaten() create icon from data
' that was set in hta.
' Input data in hta: Open ico-file with pspad-editor in
' hex-view, press [ctrl-a], [ctrl-c] and paste the clipboard-
' string to variable 'Tst' in Hta-code.
'
' Vergl.
' http://dieseyer.de/scr/WIM-BuR.hta
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst
Tst = "0000010001002020000001001800A80C00001600000028000000200000004000000001001800000000000000000048000000480000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFBFBFBFDFDFDF2F2F2F5F5F5F0F0F0FFFFFFFFFFFFFAFAFAE1E1E1E6E6E6E6E6E6ECECECF4F4F4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFCE9E9E9ECECECF6F6F6FFFFFFF1F1F1E0E0E0F0F0F0FEFEFEFFFFFFFAFAFAEDEDEDF6F6F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFDFDFDFDFDFDEDEDEDE7E7E7FBFBFBF8F8F8DEDEDEE5E5E5FDFDFDFFFFFFFFFFFFFDFDFDFFFFFFFFFFFFF3F3F3F2F2F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8F6F6F6F2F2F2FBFBFBEEEEEED3D3D3ECECECFFFFFFFFFFFFFFFFFFF8F8F8E5E5E5FBFBFBFFFFFFFFFFFFF5F5F5FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF2F2F2F2F2F2FBFBFBE8E8E8D9D9D9F0F0F0FFFFFFFFFFFFFFFFFFFCFCFCAFAFAF9B9B9BE0E0E0FDFDFDFFFFFFFFFFFFFCFCFCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFEDEDEDE7E7E7DFDFDFF5F5F5FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFECECECF2F2F2F2F2F2FDFDFDFFFFFFF6F6F6FDFDFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE9E9E9DFDFDFD6D6D6F8F8F8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE0E0E0BDBDBDF0F0F0FFFFFFFAFAFAE4E4E4FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE9E9E9C5C5C5EAEAEAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFEFEFEFFFFFFD5D5D5F9F9F9FFFFFFFCFCFCBBBBBBF8F8F8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE2E2E2BEBEBEFAFAFAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEE5E5E5E4E4E4FBFBFBD7D7D7E0E0E0D7D7D7D5D5D5B4B4B4DCDCDCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5F5F5CCCCCCC3C3C3EFEFEFFFFFFFE1E1E1DFDFDFF7F7F7DBDBDBD3D3D3ECECECB8B8B8DFDFDFDDDDDDD9D9D9AEAEAECFCFCFE7E7E7DCDCDCD9D9D9FDFDFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFCD9D9D9BBBBBBDEDEDEE7E7E7F7F7F7E4E4E4C5C5C5D8D8D8C1C1C1A1A1A1C2C2C2B6B6B6BBBBBBDFDFDFC9C9C9B5B5B5D7D7D7E5E5E5D0D0D0C6C6C6E6E6E6F9F9F9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8EEEEEEBCBCBCDFDFDFC2C2C2E5E5E5FCFCFCFFFFFFCDCDCDDEDEDEE8E8E8BABABAE9E9E9ACACAC5F5F5FA3A3A3AEAEAE7272728C8C8C646464A3A3A3B1B1B1C2C2C2E6E6E6F8F8F8F3F3F3FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8BFBFBFBCBCBCE3E3E3DADADAEEEEEEFFFFFFFFFFFFFEFEFEA3A3A3FDFDFDB6B6B63737379898987B7B7B5B5B5BACACACDBDBDBAAAAAAC6C6C67E7E7E6F6F6FADADADB3B3B3AEAEAEDFDFDFD3D3D3F3F3F3FFFFFFFFFFFFFFFFFFFFFFFFCDCDCD6A6A6AADADADE7E7E7DCDCDCE9E9E9FBFBFBFFFFFFFCFCFCBBBBBBDFDFDFA4A4A4ABABABC0C0C0575757A4A4A4FBFBFBF6F6F6F7F7F7FBFBFBDBDBDB8888889F9F9FA1A1A1808080B3B3B3B0B0B0D3D3D3FDFDFDFFFFFFFFFFFFFFFFFF717171555555999999DDDDDDB5B5B5CECECEF7F7F7DDDDDDBEBEBEB8B8B8D6D6D6B0B0B05757576C6C6CB0B0B0E8E8E8FFFFFFFFFFFFFFFFFFFFFFFFFEFEFEA4A4A4F9F9F9E9E9E98888888C8C8C8F8F8FBDBDBDE6E6E6FFFFFFFFFFFFFFFFFF4747474A4A4A707070A3A3A3B4B4B4B2B2B2D0D0D0AAAAAA979797969696A3A3A3717171535353CECECEE0E0E0DBDBDBFFFFFFFFFFFFFFFFFFFFFFFFF6F6F6A8A8A8FEFEFEE5E5E59696967979796F6F6F9D9D9DC6C6C6FDFDFDFFFFFFFFFFFF4A4A4A3B3B3B6464647C7C7C9595957C7C7C9595958484846A6A6A4D4D4D5C5C5C747474A3A3A3B9B9B9EEEEEEC6C6C6FEFEFEFFFFFFFFFFFFFFFFFFE1E1E1ABABABFEFEFEBBBBBBA7A7A78787875151518C8C8CB4B4B4FBFBFBFFFFFFFFFFFF4848483E3E3E7474748A8A8A7A7A7A6060608383838585858A8A8A6C6C6C747474959595949494929292FBFBFBB4B4B4F7F7F7FFFFFFFFFFFFFFFFFFBFBFBFB7B7B7F4F4F4858585AFAFAF7A7A7A4141417D7D7DA1A1A1F7F7F7FFFFFFFFFFFF5252525151512525257B7B7B6D6D6D515151787878787878A6A6A68F8F8F333333717171A6A6A6939393D1D1D1C4C4C4EBEBEBFFFFFFFFFFFFFEFEFE9F9F9FDCDCDCCDCDCD747474A8A8A86C6C6C6E6E6E656565777777EDEDEDFFFFFFFFFFFF5757576060605D5D5D8D8D8D6E6E6E6868687171716F6F6F8484848F8F8F6E6E6E515151979797BBBBBB828282E2E2E2DADADAFDFDFDFFFFFFFDFDFDBCBCBCF5F5F58D8D8D6666669A9A9A8383835F5F5F6C6C6C787878E9E9E9FFFFFFFFFFFF3D3D3D6E6E6E7A7A7A6969697878786E6E6E6A6A6A6262627C7C7C9898986E6E6E909090838383AEAEAE9D9D9D909090C3C3C3848484AAAAAAD4D4D4BDBDBDDCDCDC7D7D7D9494949999999898986767678E8E8E808080E9E9E9FFFFFFFFFFFF5959595252527E7E7E7575758B8B8B8A8A8A7E7E7E9696968686867A7A7A949494959595C9C9C9C7C7C7CECECEC2C2C2C4C4C4A8A8A8C1C1C1C8C8C8D6D6D6CBCBCBB5B5B5BFBFBFC2C2C2BEBEBE8A8A8A9393937A7A7AE7E7E7FFFFFFFFFFFF686868666666797979909090939393ABABAB888888999999B1B1B17D7D7DB9B9B9A7A7A7E4E4E4E8E8E8E7E7E7EEEEEEDADADADEDEDEE3E3E3FDFDFDF3F3F3EDEDEDF6F6F6F5F5F5DBDBDBE3E3E3D0D0D08B8B8B888888F9F9F9FFFFFFFFFFFF676767B0B0B0888888AAAAAAAFAFAFC8C8C89696969F9F9FBABABACDCDCDC6C6C6F0F0F0CECECEE1E1E1E1E1E1EDEDEDF8F8F8CFCFCFEBEBEBF5F5F5F5F5F5F8F8F8FDFDFDE3E3E3DDDDDDEFEFEFECECEC808080D5D5D5FFFFFFFFFFFFFFFFFF7A7A7A787878AFAFAFD6D6D6E0E0E0DFDFDFE5E5E5D1D1D1CCCCCCD9D9D9C3C3C3D5D5D5FDFDFDF8F8F8D4D4D4F0F0F0EAEAEAE8E8E8FDFDFDF2F2F2E5E5E5F7F7F7BDBDBDE0E0E0F4F4F4F8F8F8BFBFBFD3D3D3FEFEFEFFFFFFFFFFFFFFFFFF8B8B8B929292AFAFAFCACACAFCFCFCFDFDFDBEBEBEF4F4F4DBDBDBB5B5B5F4F4F4D3D3D3D0D0D0FEFEFEFFFFFFDDDDDDB6B6B6E5E5E5FFFFFFE9E9E9CFCFCFF9F9F9FFFFFFF4F4F4F0F0F0D8D8D8D1D1D1F9F9F9FFFFFFFFFFFFFFFFFFFFFFFFB7B7B79D9D9D676767E4E4E4E5E5E5DFDFDFEFEFEFCCCCCCF3F3F3F1F1F1DBDBDBFAFAFAEAEAEAD8D8D8F5F5F5CCCCCCCFCFCFE1E1E1F6F6F6F4F4F4F9F9F9E4E4E4D8D8D8F1F1F1E6E6E6C7C7C7EBEBEBFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8B0B0B0747474999999CFCFCFD3D3D3D7D7D7F1F1F1DCDCDCF0F0F0E7E7E7DEDEDEEDEDEDF6F6F6C9C9C9B8B8B8E1E1E1EDEDEDDADADAC3C3C3E4E4E4F3F3F3F2F2F2E2E2E2D4D4D4DADADAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1F1F1AFAFAF8A8A8AC5C5C5DADADACFCFCFD5D5D5F7F7F7EFEFEFE3E3E3E0E0E0D9D9D9D5D5D5BFBFBFC6C6C6E7E7E7FCFCFCF8F8F8E7E7E7F8F8F8F8F8F8F1F1F1CACACAD8D8D8F2F2F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1F1F1CACACAA4A4A4B1B1B1E1E1E1DEDEDEB9B9B9E7E7E7F6F6F6F2F2F2EBEBEBD3D3D3E1E1E1EBEBEBEFEFEFDDDDDDE0E0E0F2F2F2DBDBDBDCDCDCD9D9D9DCDCDCDFDFDFFDFDFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFDFDFDE5E5E5E0E0E0A9A9A9D2D2D2DDDDDDE5E5E5DFDFDFFAFAFAFAFAFAEDEDEDE5E5E5F8F8F8F0F0F0E7E7E7E8E8E8E1E1E1C5C5C5BEBEBEE9E9E9E9E9E9FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0F0F0DFDFDFECECECF2F2F2C5C5C5C0C0C0EFEFEFF7F7F7C4C4C4D5D5D5D5D5D5F6F6F6FEFEFEF4F4F4EEEEEEECECECDEDEDEE2E2E2FBFBFBFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
IcoAusHexDaten WScript.ScriptFullName & ".ico", Tst
MsgBox "Erledigt: " & WScript.ScriptFullName & ".ico", , WScript.ScriptName
WScript.Quit
'*** v9.4 *** www.dieseyer.de ******************************
Sub IcoAusHexDaten( ZielDatei, HexDaten )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileOut, Tst, i
' Läßt sich die ZielDatei anlegen?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
Set FileOut = fso.OpenTextFile( ZielDatei, 2, True )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then Exit Sub
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 1
Do
FileOut.Write Chr( CInt( "&H" & Mid( HexDaten, i, 2 ) ) )
i = i + 2 : If i > Len( HexDaten ) Then Exit Do
Loop
FileOut.Close
Set FileOut = nothing
' CreateObject("WScript.Shell").SendKeys "{F5}"
End Sub ' IcoAusHexDaten( ZielDatei, HexDaten )
#########################################################################
>>> icq5-verlauflesen.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: icq5-verlauflesen.vbs
' Autor: mike-winxp@gmx.de
' Auf: www.dieseyer.de
'
' Skript zum Lesen einer Verlaufsdatei (von icq5; ICQ v5.x).
' Die xml-Datei auf das Script ziehen und fallen lassen.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim epochdatum, shell, fso, I, a, pfad1, pfad, ergebnis, read, zeile, Farbe, messenge, objArgs
Set objArgs = WScript.Arguments
Set shell = Wscript.CreateObject("Wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Const tempdatei = "IcqNachrichten.hta"
' 1. Argumente aufnehmen
For I = 0 to objArgs.Count - 1
pfad = objArgs(I)
Next
' 2. Kontrolle (handelt es sich überhaupt um eine xml-Datiei?)
If instrRev(Right(pfad,3),"xml",-1,1) <> 1 Then
a = Msgbox ("Dieses Script funktioniert nur für xml-dateien von Icq",64,"Geht net")
Wscript.Quit
End If
' 3.Erstelle Dokument
Set ergebnis = fso.OpenTextFile(tempdatei,2,True)
ergebnis.WriteLine "<head>"
ergebnis.WriteLine "<title>Icq Nachrichten lesen</title>"
ergebnis.WriteLine "<" & "HTA:APPLICATION ID=""oHTA"""
ergebnis.WriteLine "Windowstate=""maximize"">"
ergebnis.WriteLine "<style type='text/css'>"
ergebnis.WriteLine "body,td,th {color: #CCCCCC;font-family: Arial, Helvetica, sans-serif;font-size: 10px;}body {background-color: #4a4a4a;}a {font-size: 10px;color: #CCCCCC;}a:link {text-decoration: none;}"
ergebnis.WriteLine "a:visited {text-decoration: none;color: #CCCCCC;}a:hover {text-decoration: underline;}a:active {text-decoration: none;}.Stil1 {font-size: 14px}.Stil2 {font-size: 10px; }"
ergebnis.WriteLine "</style></head><body>"
ergebnis.WriteLine "<table width='1148' border='0' align='center' bgcolor='3a3a3a' style='border: 1px outset #CCCCCC' height='146' > "
ergebnis.WriteLine "<tr><td height='142' width='1138'><div align='center'><table width='85%' border='0' align='center' bgcolor='#3a3a3a' ><div align='center' style='width: 888; height: 27'>"
ergebnis.WriteLine "<p class='Stil1'><font size='5'>Nachrichten an Icq Nummer: " & Left(Right(pfad,18),9) & "</font></p></div></table><p> </p>"
ergebnis.WriteLine " "
' 4.Liest die Datei aus
Set read = fso.OpenTextFile(pfad,1,True)
Do While read.AtEndOfStream <> True
zeile = read.ReadLine()
' von wem stammte die Nachricht?
If Instr(1,zeile, "<incoming>" ,1) >= 1 Then
ergebnis.WriteLine "<table width='1075' border='1' align='center' bgcolor='#3a3a3a' height='25' bordercolorlight='#C0C0C0' >"
If Instr(1,zeile, "<incoming>No</incoming>" ,1) >= 1 Then
Farbe = "#FF0000"
Else
Farbe = "#00FF00"
End If
End If
' Wann wurde die Nachricht verfasst?
If Instr(1,zeile, "<time>" ,1) >= 1 Then
Call epoch(Mid(zeile,8,10)) ' epochdatum
ergebnis.WriteLine "<td height='21' width='125'><font size='2'>" & epochdatum & "</font>"
End If
' Was wurde geschrieben?
If Instr(1,zeile, "<text>" ,1) >= 1 Then
messenge = right(zeile,Len(zeile)-7)
If Instr(1,messenge, chr(195),1) >= 1 Then
messenge = Replace(messenge, chr(195) & chr(188), "ü")
messenge = Replace(messenge, chr(195) & chr(182), "ö")
messenge = Replace(messenge, chr(195) & chr(159), "ß")
messenge = Replace(messenge, chr(195) & chr(164), "ä")
messenge = Replace(messenge, chr(195) & chr(150), "Ö")
messenge = Replace(messenge, chr(195) & chr(132), "Ä")
messenge = Replace(messenge, chr(195) & chr(156), "Ü")
End If ' messenge
ergebnis.WriteLine "<td height='21' width='925'><font size='3' color='" & Farbe & "'>" & messenge & "</font></table>"
End If
Loop
read.Close
ergebnis.WriteLine "<p><font size='3' color='#FF0000'>ausgehende Nachricht "
ergebnis.WriteLine "</font><font size='3' color='#00FF00'>ankommende Nachricht</font></p>"
ergebnis.WriteLine "<p> </p></div></td></tr></table></body>"
ergebnis.close
shell.Run tempdatei,1, True
fso.DeleteFile(tempdatei)
Wscript.Quit
'**************************************************************
Function epoch(epochtime)
epochdatum = DateAdd("s", epochtime, "01/01/1970 01:00:00")
End Function
#########################################################################
>>> icq6-verlauflesen.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: icq6-verlauflesen.vbs
' Autor: mike-winxp@gmx.de
' Auf: www.dieseyer.de
'
' Skript zum Lesen einer Verlaufsdatei (von icq6; ICQ v6.x).
' Dazu einfach die "Messages.mdb"-Datei auf das Script ziehen
' und fallen lassen. Die Datei befindet sich (unter WinXP):
' C:\Dokumente und Einstellungen\[UserName]\Anwendungsdaten\ICQ\[ICQ Nummer]\Messages.mdb
' %APPDATA%\ICQ\[Ihre ICQ Nummer]\Messages.mdb
'
'************************************************************
Option Explicit
Dim shell, db, ie, objArgs, x, pfad, dok, i, antwort, userid, history, messenge, Title, Nummer, Farbe, zahl, Icq_killen ,prozess
Set shell = CreateObject("WScript.Shell")
Set db = CreateObject("ADODB.Connection")
Set ie = CreateObject("InternetExplorer.Application")
Set objArgs = WScript.Arguments
For x = 0 To objArgs.Count - 1
pfad = objArgs(I)
Next
If pfad = "" Then
pfad = shell.SpecialFolders("AppData") & "\ICQ\[Ihre ICQ Nummer]\Messages.mdb" ' Bitte tragen sie ihre ICQ-Nummer ein
If instr(1, pfad, "[Ihre ICQ Nummer]", 1) > 1 Then Msgbox "Bitte passen Sie den Pfad an",16,"Error" : Wscript.Quit
End If
For Each prozess In GetObject("winmgmts:{impersonationLevel=impersonate,(Debug)}").ExecQuery ("SELECT * FROM Win32_Process")
If Instr("ICQ.exe",prozess.Name) > 0 Then
Icq_killen = Msgbox ("Anscheinend läuft ICQ noch. Um auf die Datenbank zugreifen zu können muss ICQ beendet werden" &_
vbCr & vbCr & "Wollen sie Icq jetzt beenden?" & vbCr &_
"Wählen Sie 'Ja' um ICQ jetzt zu beenden (ACHTUNG: Dadurch wird der Task ICQ.exe ""gekillt"")" & vbCr &_
"Wählen Sie 'Nein' um mit dem Script fortzufahren (Beenden Sie vorher ICQ manuell)" & vbCr &_
"Wählen Sie 'Abbrechen' um das Script abzubrechen" , 563 ,"ICQ läuft noch. Wie möchten sie fortfahren?")
If Icq_killen = 7 Then Msgbox "Bitte beenden Sie ICQ jetzt!",64, "ICQ jetzt beenden"
If Icq_killen = 2 Then wscript.Quit
If Icq_killen = 6 Then prozess.Terminate(0)
End If
Next
zahl = InputBox("Bitte geben Sie an, wieviele Nachrichten angezeigt werden sollen.", "Icq6 Verlauf", "500")
If zahl = 0 Then Wscript.Quit
ie.Navigate "about:blank"
While ie.Busy
Wend
Set dok = ie.Document
dok.Open
dok.Writeln "<Title>Verlauf Icq6</Title><B>Datenbank wird gelesen. Bitte warten . . . </b>"
dok.Close
ie.Visible = True
wscript.sleep 100
shell.AppActivate("Verlauf Icq6")
shell.SendKeys "% x"
db.Open("DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & pfad)
Set antwort = db.Execute("SELECT * FROM Messages" & " ORDER BY date DESC")
Set userid = db.Execute("SELECT * FROM Users")
Set history = db.Execute("SELECT * FROM ChatHistory")
For i = 0 To zahl
If antwort.EOF = True Then Exit For
x = x + 1 : If x = 10 Then Wscript.Sleep 3 : x = 0 ' Soll für geringere Prozessorauslastung sorgen
If "" & antwort(1) = "" Then
Farbe = "red"
Else ' black; maroon; green; olive; navy; purple; teal; gray; silver; red; lime; yellow; blue; fuchsia; aqua
Farbe = "blue"
End If
messenge = "<tr><td>" & Left(antwort(6),6) & Mid(antwort(6),9,8) & "</td><td> " &_
antwort(2) & "</td><td> " & antwort(1) & " </td><td><font color='" & Farbe & "'> " &_
antwort(8) & "</font></td></tr>" & messenge ' Damit die neueste Nachricht ganz oben steht muss es 'messenge = messenge & "....'
antwort.MoveNext
Next
Title = "<Title>Verlauf Icq6</Title><u><B>Gespräch mit:</b></u><BR>"
Nummer = "<u><B>User haben folgende Nummern:</b></u><BR>"
x = 0
Do Until userid.EOF
x = x + 1
messenge = Replace(messenge,userid(0),userid(1))
messenge = Replace(messenge, history(0), x)
Title = Title & userid(1) & " = " & x & "; "
Nummer = Nummer & userid(1) & " = " & userid(0) & "; "
userid.MoveNext
history.MoveNext
Loop
Title = Title & "<BR><BR><u><B>Verlauf:</b></u><BR>Die letzten " & zahl & " Nachrichten werden angezeitg<BR><table border='1' cellpadding='0' cellspacing='0' width='99%'>" &_
"<tr><td><B><center>Datum/Uhrzeit</center></td><td><B><center>ID</center></td><td><B><center>Name</center></td><td><B><center>Nachricht</center></td>"
dok.Open
dok.Write(Nummer & "<BR><BR>" & Title & "<BR><center><font color='blue'>eingehende Nachrichten</font> " &_
"<font color='red'>ausgehende Nachrichten</font></center><BR> " & messenge)
dok.Close
#########################################################################
>>> ie-start.vbs <<<
'v4.3*****************************************************
' 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 ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 vom 10.02.2004
Const DNS2 = "145.253.2.75" ' Arcor vom 10.02.2004
Const DNS3 = "62.104.191.241" ' FreeNet.de vom 10.02.2004
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 ) ' 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 ) ' 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
#########################################################################
>>> immerwieder.vbs <<<
'v5.B*****************************************************
' File: immerwieder.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Startet regelmäßig verschiedene Skripte.
'
'*********************************************************
' Das Skript beendet sich, wenn es gelöscht wird.
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim n
Dim nach : nach = Array( 10, 20, 30, 50, 59 ) ' gestartet werden "10.vbs" "20.vbs" .. "59.vbs"
MsgBox "Es geht los!", , "0020 :: " & WScript.ScriptName
' MsgBox UBound( nach ), , "0022 :: " & WScript.ScriptName
Do
For n = LBound( nach ) To UBound( nach )
If Second(now) = nach( n ) Then
' If Minute(now) = nach( n ) Then
' WSHShell.Run( nach( n ) & ".vbs" )
MsgBox nach( n ) & ".vbs", , "0029 :: " & WScript.ScriptName
End If
Next
WScript.Sleep 250 ' alle 1/4 Sekunde bei ==>> "If Second(now) = nach( n ) Then" <<==
' WScript.Sleep 15*1000 ' alle 1/4 Minute bei ==>> "If Minute(now) = nach( n ) Then" <<==
If Not fso.FileExists( WScript.ScriptFullName ) Then Exit do
Loop
MsgBox "Das wars!", , "0038 :: " & WScript.ScriptName
#########################################################################
>>> input.hta <<<
</html>
<head>
<!--
'v5.B*****************************************************
' File: input.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' ermöglicht die Eingabe von drei Parametern . . .
'
'*********************************************************
zu HTA ==> http://msdn.microsoft.com//workshop/author/hta/hta_node_entry.asp
zu HTML ==> http://selfhtml.org/ bzw. Download
==> http://aktuell.de.selfhtml.org/extras/download.shtml#adressen
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
-->
<HTA:APPLICATION ID="oHTA"
BORDER="none" <!-- -->
INNERBORDER="no" <!-- -->
SCROLL="No" <!-- -->
NAVIGABLE="yes" <!-- -->
APPLICATIONNAME="Service.CD Anmeldung"
>
<!-- <title># input.hta #</title> wird in der Taskleiste angezeigt -->
<title># input.hta #</title>
<style type="text/css">
TD {font-size:12Pt; color:#E0C000; font-style:bold; font-family:Arial, Verdana}
input {font-size:12pt; color:#202060; font-style:bold; font-family:Verdana}
H2 {font-size:18pt; color:#E0C000; font-style:bold; font-family:Verdana}
</style>
</head>
<script language="VBscript">
Const Titel = "input.hta" ' für MsgBox / PopUp
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim WSHnet : Set WSHnet = CreateObject("WScript.NetWork")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
'****************************************
sub Install()
'****************************************
Dim AnzTage
AnzTage = Document.All.xTage.Value
AnzTage = CInt( AnzTage )
If AnzTage = 0 Then MsgBox "Ein Jahr hat """ & AnzTage & """ Tage?" & vbCRLF & vbCRLF & "Es geht doch wohl etwas genauer, oder?!", , "0055 :: " & Titel : Exit Sub
If AnzTage = 333 Then MsgBox "Wieviel Tage hat ein Jahr?! """ & AnzTage & """ Tage?" & vbCRLF & vbCRLF & "Bitte ETWAS Mühe geben!" , , "0056 :: " & Titel : Exit Sub
If AnzTage < 365 Then MsgBox "Könnte ein Jahr ein paar Tage mehr als """ & AnzTage & """ Tage haben?" & vbCRLF & vbCRLF & "Es geht doch wohl etwas genauer, oder?!", , "0057 :: " & Titel : Exit Sub
If AnzTage > 366 Then MsgBox "Könnte ein Jahr ein paar Tage weniger als """ & AnzTage & """ Tage haben?" & vbCRLF & vbCRLF & "Es geht doch wohl etwas genauer, oder?!", , "0058 :: " & Titel : Exit Sub
If AnzTage = 366 Then MsgBox "Sogar ans Schaltjahr gedacht - alle Achtung!" , , "0059 :: " & Titel ' kein : Exit Sub
Dim UName
UName = Document.All.xName.Value
If UName = "" Then MsgBox "Sieh doch mal im Ausweis nach . . . und trage dann bitte deinen RICHTIGEN Namen ein!", , "0063 :: " & Titel : Exit Sub
Dim WochenEnde
If Document.All.opt1.checked Then WochenEnde = "WE"
If Document.All.opt2.checked Then WochenEnde = "keinWE"
If WochenEnde = "" Then MsgBox "Ist nun heute Wochenenede oder nich?!", , "0068 :: " & Titel : Exit Sub
Dim Txt
Txt = " " & "Das waren die Eingaben:"
Txt = Txt & vbCRLF & AnzTage & vbTab & " Tage soll ein Jahr haben."
Txt = Txt & vbCRLF & UName & vbTab & " wurde als Name eingegeben."
Txt = Txt & vbCRLF & WochenEnde & vbTab & " soll heute sein."
MsgBox Txt, , "0075 :: " & Titel
self.close
End Sub ' Install()
'**************************************************************
Sub Schliessen()
'**************************************************************
MsgBox "Dann eben nicht!", , Titel
self.close
End Sub ' Schliessen()
'**************************************************************
Sub document_onKeyDown
'**************************************************************
If window.event.keyCode = 13 Then Call Install()
End Sub
'**************************************************************
Function BeimLaden() ' ruft einige Routinen auf
'**************************************************************
Txt = ""
Txt = Txt & "<fieldset><Legend > Bitte Name eineben: </legend>"
Txt = Txt & "<BR>"
Txt = Txt & " <input Type=""Text"" Name=""xName"" VALUE=""" & WSHnet.UserName & """ > "
Txt = Txt & "<BR><BR>"
Txt = Txt & "</fieldset>"
document.all.NetUserAnzeige.innerHTML = Txt
Txt = ""
Txt = Txt & "<fieldset><Legend align=""Center""> Ist heute Wochenende? </legend>"
<!-- Txt = Txt & "<fieldset><Legend > Ist heute Wochenende? </legend>" -->
Txt = Txt & " <input type=""radio"" name=""R1"" ID=""opt1"" value=""ja""> Ja - heute ist Wochenende!<br>"
Txt = Txt & " <input type=""radio"" name=""R2"" ID=""opt2"" value=""nein""> Nein - ich muss arbeiten!<br>"
<!-- Txt = Txt & " <input checked type=""radio"" name=""R2"" ID=""opt2"" value=""nein""> Nein - ich muss arbeiten!<br>" -->
Txt = Txt & "<BR>"
Txt = Txt & "</fieldset>"
document.all.WeekEnd.innerHTML = Txt
End Function ' BeimLaden()
</script>
<body onLoad="BeimLaden()" bgcolor="#202060" >
<form>
<BR><BR>
<h2 align="center">. . . bitte ausfüllen . . .
<table border="0" cellspacing="10px" width="100%">
<tr>
<td bgcolor=#1d2160 >
<!-- <td bgcolor=#1d2160 align="center" cellspacing="70%" > -->
<fieldset><Legend align="Center"></legend>
Wieviel Tage hat ein Jahr?
<BR><BR>
<input Type="Text" Name="xTage" Value="333" >
<BR><BR>
</fieldset>
<div id=NetUserAnzeige> </div>
<div id=WeekEnd> </div>
<BR>
<INPUT TYPE="Button" Name="StartVBS" value="Start" onClick="Install()" >
<INPUT TYPE="Button" Name="EndeHTA" value="Beenden" onClick="Schliessen()" >
<BR><BR>
</td>
</tr>
</table>
</form>
</body>
</html>
#########################################################################
>>> 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
'*******************************************************
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 ) ' 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-adresse2.vbs <<<
'v5.1***************************************************
' File: ip-dresse2.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt den PC-Name und alle IP-Adressen
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox AllIPadr(), , WScript.ScriptName ' Function - Aufruf
WScript.Quit
'*******************************************************
Function AllIPadr() ' www.dieseyer.de - v5.2
'*******************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WshSysEnv : Set WshSysEnv = WSHShell.Environment("SYSTEM")
Dim Ziel, TextX, i1, IPAdr
Ziel = "winipcfg.out"
Set WshSysEnv = WSHShell.Environment("PROCESS")
if WshSysEnv("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
Dim FileIn : Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' 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
End Function ' AllIPadr() - www.dieseyer.de - v5.2
#########################################################################
>>> ip-adresse3.vbs <<<
'v5.1********************************************************
' File: ip-adresse3.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Damit die IP-Adresse mit IPCONFIG ermittelt werden kann,
' ohne dass eine Schreiboperation auf einen Datenträger
' erfolgt, werden im 'unsichtbaren' Aufruf von
' exechiddenplus.vbs alle IPCONFIG-Ausgaben abgefangen
' und ausgewertet.
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox IPadr, , WScript.ScriptName ' mit Function Aufruf
WScript.Quit
' http://dieseyer.de/scr-html/exechiddenplus.html
' http://dieseyer.de/scr/exechiddenplus.vbs
' so muss die "exechiddenplus.vbs" innen aussehen:
'
' set oArgs = Wscript.Arguments
' For i = 0 to oArgs.Count - 1
' if Instr( oArgs.item(i), " " ) > 0 Then CMD = CMD & """" & oArgs.item(i) & """" & " "
' if not Instr( oArgs.item(i), " " ) > 0 Then CMD = CMD & oArgs.item(i) & " "
' Next
' Set oExec = WScript.CreateObject("WScript.Shell").Exec( CMD )
' Do Until oExec.status : WScript.Sleep 100 : Loop
' WScript.CreateObject("WScript.Shell").Environment( "volatile" )( "Eregbnis" ) = oExec.StdOut.ReadAll()
'**************************************************************
Function IPadr() ' v5.2 - http://dieseyer.de
'**************************************************************
Dim Txt, Tst, i
Dim WshShell : Set WshShell = CreateObject("Wscript.Shell")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
Dim ExecH : ExecH = "exechiddenplus.vbs"
' MsgBox fso.GetAbsolutePathName( ExecH ) & vbCRLF & vbCRLF & "existiert.", , WScript.ScriptName
if not fso.FileExists( ExecH ) Then
MsgBox fso.GetAbsolutePathName( ExecH ) & vbCRLF & vbCRLF & "f e h l t ! ! !", , WScript.ScriptName
Else
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "CScript.exe //NOLOGO " & ExecH & " %comspec% /c ipconfig /all" , 0, true
Txt = WshShell.Environment("volatile")( "Eregbnis" )
Set WshShell = nothing
Tst = Split(Txt, vbCRLF, -1)
' MsgBox "LBound: " & LBound( Tst ) & vbCRLF & "UBound: " & UBound( Tst ) & vbCRLF & Txt, , WScript.ScriptName
For i = LBound( Tst ) to UBound( Tst )
If InStr( Tst( i ), "IP-A" ) > 0 OR InStr( Tst( i ), "IP A" ) > 0 Then
Tst( i ) = Replace( Tst( i ) , vbCR, "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , vbLF, "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , ". .", "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , ". ", "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Mid( Tst( i ) , InStr( Tst( i ) , " : ") + 2 )
Tst( i ) = Replace( Tst( i ) , " ", "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , " ", "" ) ' überflüssige Zeichen entfernen
Txt = "---"
' If InStr( Tst( i ), "169.254." ) = 1 Then Txt = "<strike>" & Tst( i ) & " noDHCP</strike>"
If InStr( Tst( i ), "169.254." ) = 1 Then Txt = Tst( i ) & " noDHCP"
' If InStr( Tst( i ), "0.0.0.0" ) = 1 Then Txt = "<strike>" & Tst( i ) & " noDHCP</strike>"
If InStr( Tst( i ), "0.0.0.0" ) = 1 Then Txt = Tst( i ) & " noDHCP"
If InStr( Tst( i ), "53.79.186." ) = 1 Then Txt = Tst( i ) & " Bereich II"
If InStr( Tst( i ), "53.79.187." ) = 1 Then Txt = Tst( i ) & " Bereich VI"
If InStr( Tst( i ), "53.72.161." ) = 1 Then Txt = Tst( i ) & " Labor"
If Txt = "---" Then Txt = Tst( i ) & " OK"
Tst( i ) = Txt
If not IPadr = "" Then IPadr = IPadr & vbCRLF & Tst( i )
If IPadr = "" Then IPadr = Tst( i )
End If
Next
End If
'**************************************************************
End Function ' IPadr() v5.2 - http://dieseyer.de
'**************************************************************
#########################################################################
>>> ip-aus-name.vbs <<<
'v2.5***************************************************
' File: ip-aus-name.vbs
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' Programm ermittelt die IP-Adressen aus einem PC-Name
'*******************************************************
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 ) ' 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
#########################################################################
>>> ip-aus-name2.vbs <<<
'*** v4.B *** www.dieseyer.de *******************************
'
' Datei: ip-aus-name2.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Programm ermittelt die IP-Adressen aus einem PC-Name
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim PCName
PCName = wshnet.ComputerName
PCName = "Server01"
PCName = InputBox( vbCRLF & vbCRLF & "Von welchem PC soll IP-Adresse ermittelt werden?", WScript.ScriptName, PCName )
MsgBox IPAdr(PCName), ,WScript.ScriptName
'*** v4.B *** www.dieseyer.de *******************************
Function IPAdr( PC )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oExec : Set oExec = WshShell.Exec("%comspec% /c Ping " & PC & " -n 1 -w 500" )
Do While Not oExec.StdOut.AtEndOfStream
IPadr = oExec.StdOut.ReadLine
If InStr( IPadr, "TTL=") Then
IPadr = Mid( IPAdr, 1, InStr( IPAdr, ":")-1)
' Löscht alles hinter ":" und das ":"
IPadr = Mid( IPAdr, InStrRev(IPAdr, " ") +1 )
' von Rechts beginnend (InStrRev) wird alles vor dem
' ersten Leerzeichen gelöscht
IPadr = "==>" & IPadr & "<=="
Exit Do
End If
Loop
End Function ' IPAdr( PC )
#########################################################################
>>> ipadr-dns.vbs <<<
'WINS/DNS Query
'By Steve Barton 2/23/09
'On Error Resume Next
strComputer="S010A45SMA002"
strComputer="M010D2500020733"
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration", "WQL", _
wbemFlagReturnImmediately + wbemFlagForwardOnly)
For Each objItem In colItems
strIPAddress = Join(objItem.IPAddress, ",")
strDNSServerSearchOrder = Join(objItem.DNSServerSearchOrder, VBCrLf & Space(40))
If IsNull(objItem.WINSPrimaryServer)=False Then
WScript.Echo "Computer: " & strComputer & VBCrLf & "Description: " & objItem.Description & VBCrLf & "IPAddress: " & strIPAddress & VBCrLf & _
"DNSDomain: " & objItem.DNSDomain & VBCrLf & "DNSServerSearchOrder: " & strDNSServerSearchOrder & VBCrLf & _
"WINSPrimaryServer: " & objItem.WINSPrimaryServer & VBCrLf & "WINSSecondaryServer: " & objItem.WINSSecondaryServer
End If
Next
#########################################################################
>>> 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.
'*********************************************************
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
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 ) ' 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)
#########################################################################
>>> kontext-anzahlzeichenimpfad.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: kontext-anzahlzeichenimpfad.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Erstellt für www.roton.de
'
' Im Kontext-Menü des Windows-Explorers wird ein Eintrag
' hinzugefügt:
' "Anzahl der Zeichen im Pfad ermitteln"
' durch den die Anzahl der Zeichen des Pfades zu einer
' Datei bzw. zu einem Verzeichnis ermittelt und
' angezeigt wird.
'
' Werden mehrer Dateien / Verzeichnisse übergeben, wird nur
' ein Parameter verwendet (der erste oder der letzte).
'
' Beim direkten Aufruf des VBS wird geprüft, ob es bereits
' 'installiert' ist - wenn ja wird eine 'Deinstallation'
' angeboten.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const AnzTeilen = 88 ' wenn die Länge des Pfades "AnzTeilen" übersteigt, wird die Anzeige des Pfades 'geteilt'
Const KontextName = "Anzahl der Zei&chen im Pfad ermitteln"
Dim ContextFunc
Const HKCRShellA = "HKCR\*\shell" ' Erweiterung für Dateien
Const HKCRShellB = "HKCR\Folder\shell" ' Erweiterung für Verzeichnisse
Const VBSVerz = "dieseyer.de" ' wird zu %ProgramFiles%\dieseyer.de; C:\Programme\dieseyer.de
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim DieseyerVerz : DieseyerVerz = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
Dim i, n, Txt, Tst
' Ist das Skript bereits installiert?
If oArgs.Count < 1 AND fso.FileExists( DieseyerVerz ) Then
SkriptDeinst( "049 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' Ist das Skript bereits installiert?
If oArgs.Count < 1 AND Ucase( DieseyerVerz ) = UCase( WScript.ScriptFullName) Then
SkriptDeinst( "055 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' es muss ein Parameter vorhanden sein
If oArgs.Count < 1 Then
SkriptInfo( "061 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' WSHShell.Popup "= = = S T A R T = = =", 2, "065 :: " & WScript.ScriptName
Txt = ""
Txt = oArgs.item( 0 ) ' Der erste Parameter
If Len( Txt ) < AnzTeilen Then
Tst = Txt
Else
Tst = InStr( Mid( Txt, 4 ), "\" ) + 6 ' das erste \ nach "X:\" oder "\\s"
Tst = Mid( Txt, 1, Tst ) ' die ersten Zeichen bis zum \
Tst = Tst & " . . . " & vbCRLF & " . . . "
Tst = Tst & Mid( Txt, InStrRev( Txt, "\" ) - 3 ) ' die Zeichen ab dem letzten \
End If
Tst = "Das sind " & Len( Txt ) & " Zeichen:" & vbCRLF & vbCRLF & Tst
WSHShell.Popup Tst, 10, "080 :: " & WScript.ScriptName
' WSHShell.Popup "= = = E N D E = = =", 1, "082 :: " & WScript.ScriptName
WScript.Quit
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptDeinst( Ttt )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript (neu) installieren." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Skript entfernen und deinstallieren." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Alles lassen, wie es ist . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "102 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call SkriptInst( "ENTFERNEN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "116 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptDeinst( Ttt )
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptInfo( Ttt )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über eine Kontext-Menü-Erweiterung im" & vbCRLF
Txt = Txt & "Windows-Explorer angesprochen werden, um eine Datei" & vbCRLF
Txt = Txt & "oder ein Verzeichnis an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript im Kontext-Menü einfügen." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbNo = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "145 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "154 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptInst( SkriptType )
'************************************************************
' Call SkriptInst( "INSTALLIERN" )
' Call SkriptInst( "ENTFERNEN" )
Dim Txt, Tst
SkriptType = UCase( SkriptType )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz
If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
If SkriptType = "INSTALLIERN" Then
fso.CopyFile WScript.ScriptFullName, Tst, True
Else
fso.CopyFile WScript.ScriptFullName, Tst & " deaktiviert.txt", True
fso.DeleteFile Tst, True
End If
If SkriptType = "INSTALLIERN" Then
WSHShell.RegWrite HKCRShellA & "\AnzZeichenImPfad\", KontextName
WSHShell.RegWrite HKCRShellA & "\AnzZeichenImPfad\Command\", "wscript.exe """ & Tst & """ " & ContextFunc & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\AnzZeichenImPfad\", KontextName
WSHShell.RegWrite HKCRShellB & "\AnzZeichenImPfad\Command\", "wscript.exe """ & Tst & """ " & ContextFunc & " " & chr(34) & "%1" & chr(34)
Else
WSHShell.RegDelete HKCRShellA & "\AnzZeichenImPfad\Command\"
WSHShell.RegDelete HKCRShellA & "\AnzZeichenImPfad\"
WSHShell.RegDelete HKCRShellB & "\AnzZeichenImPfad\Command\"
WSHShell.RegDelete HKCRShellB & "\AnzZeichenImPfad\"
End If
Txt = ""
If SkriptType = "INSTALLIERN" Then
Txt = Txt & "Das Skript """ & WScript.ScriptName & """ ist jetzt in das Kontext-Menü des" & vbCRLF
Txt = Txt & "Windows-Explorer eingetragen und über" & vbCRLF & vbCRLF
Txt = Txt & vbTab & """" & Replace( KontextName, "&", "" ) & """" & vbCRLF & vbCRLF
Txt = Txt & "erreichbar."
Else
Txt = Txt & vbTab & "Das Skript " & vbCRLF & vbCRLF
Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Txt & vbTab & "wurde gelöscht und aus dem Kontext-" & vbCRLF & vbCRLF
Txt = Txt & vbTab & "Menü des Windows-Explorer entfernt."
End If
' MsgBox Txt, , "206 :: " & WScript.ScriptName
WSHShell.Popup Txt, 9, "207 :: " & WScript.ScriptName
End Sub ' SkriptInst( SkriptType )
'*** v8.3 *** www.dieseyer.de *******************************
Sub TempHilfeHta
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "227 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "230 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "231 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "232 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, true)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta
#########################################################################
>>> kontext-besitzerwerden.vbs <<<
'*** v10.B *** www.dieseyer.de *****************************
'
' Datei: kontext-besitzerwerden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Kontext-Menü des Windows-Explorers wird ein Eintrag
' hinzugefügt: "Besitz übernehmen"
'
' Werden mehrer Dateien / Verzeichnisse übergeben, wird nur
' ein Parameter verwendet (der erste oder der letzte).
'
' Beim direkten Aufruf des VBS wird geprüft, ob es bereits
' 'installiert' ist - wenn ja wird eine 'Deinstallation'
' angeboten.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const KontextName1 = "Besitz &übernehmen"
Const ContextFunc1 = "jaNetz"
Dim ContextFunc
Const VBSVerz = "dieseyer.de" ' wird zu %ProgramFiles%\dieseyer.de; C:\Programme\dieseyer.de
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim DieseyerVerz : DieseyerVerz = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
Dim i, n, Txt, Tst
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND fso.FileExists( DieseyerVerz ) Then
SkriptDeinst( "063 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND Ucase( DieseyerVerz ) = UCase( WScript.ScriptFullName) Then
SkriptDeinst( "069 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' es müssen min. zwei Parameter vorhanden sein
If oArgs.Count < 2 Then
SkriptInfo( "075 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
ContextFunc = oArgs.item( 0 ) ' Der erste Parameter entscheidet, ob Netzlaufwerk aufgelöst werden soll oder nicht
If not ContextFunc = ContextFunc1 Then
SkriptInfo( "082 :: " ) ' Sub-Prozedur-Aufruf
' SkriptInfo( "083 :: """ & oArgs.item( 0 ) & """ " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' WSHShell.Popup "= = = S T A R T = = =", 2, "088 :: " & WScript.ScriptName
Txt = "" : Tst = ""
For i = 1 to oArgs.Count - 1 ' hole alle Argumente
Tst = oArgs.item( i )
' MsgBox i & ": " & Tst, , "093 :: "
BesitzerWerden Trim( Tst )
' Exit For ' nur ein übergebener Pfad
Next
' InPutBox "Folgendes wurde durch das Skript" & vbCRLF & vbCRLF & vbTab & """" & WScript.Scriptname & """" & vbCRLF & vbCRLF & "in der Zwischenablage (Clipboard) eingetragen:", "105 :: " & WScript.Scriptname, Tst
' WSHShell.Popup "= = = E N D E = = =", 1, "107 :: " & WScript.ScriptName
WScript.Quit
'*** v10.B *** www.dieseyer.de *****************************
Function BesitzerWerden( Pfad )
'***********************************************************
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst
Tst = "%comspec% /c CACLS.EXE """ & Pfad & """ /C /T /E /P " & WSHNet.UserName & ":F &&@echo RC '%errorlevel%'&&@pause"
' MsgBox Tst, , "89 :: "
WSHShell.Run Tst, , True
End Function ' BesitzerWerden( Pfad )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptDeinst( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript (neu) installieren." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Skript entfernen und deinstallieren." & vbCRLF
' Txt = Txt & "[Abbrechen]" & vbTab & "Alles lassen, wie es ist . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Nichts tun . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "177 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call SkriptInst( "ENTFERNEN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "191 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptDeinst( Ttt )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInfo( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über eine Kontext-Menü-Erweiterung im" & vbCRLF
Txt = Txt & "Windows-Explorer angesprochen werden, um eine Datei" & vbCRLF
Txt = Txt & "oder ein Verzeichnis an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript im Kontext-Menü einfügen." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbNo = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "220 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "229 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInst( SkriptType )
'***********************************************************
' Call SkriptInst( "INSTALLIERN" )
' Call SkriptInst( "ENTFERNEN" )
Const HKCRShellA = "HKCR\*\shell" ' Erweiterung für Dateien
Const HKCRShellB = "HKCR\Folder\shell" ' Erweiterung für Verzeichnisse
Dim Txt, Tst
SkriptType = UCase( SkriptType )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz
If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
If SkriptType = "INSTALLIERN" Then