http://dieseyer.de • all rights reserved • © 2010 v10.1
278 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 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
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 "048 :: VBSmodTest: " & VBSmodTest, 1
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
If VBSmodTest > 10 Then Exit Do
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "055 :: " & WScript.ScriptName
Trace32Log "056 :: 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( "089 :: " & WScript.ScriptFullName & " existiert nicht!" ), 1
Trace32Log( "090 :: " & WScript.ScriptFullName & " wird beendet . . . " ), 1
Trace32Log( "091 :: " & WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " ), 1
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "093 :: " & 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 "120 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "125 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "130 :: 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, , "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 )
#########################################################################
>>> 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 <<<
'*** v9.5 *** www.dieseyer.de ****************************
'
' Datei: 1und1_htmlstatistic_nach_csv.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'*********************************************************
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, "\" ) )
: QuellVerz = "D:\dieseyer.xxx\dieseyer.html"
' ~~~ 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 "030 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "031 :: LogDatei: " & LogDatei, 1
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "033 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim Txt, Tst, Tyt, i, arrDaten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDaten = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "041 :: 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 = LBound( arrDaten ) to UBound( arrDaten )
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 ) * 2 , "|" ) & "</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 "076 :: 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 ), , "102 :: " & 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 ), , "103 :: " & 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 ), , "104 :: " & 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 ), , "105 :: " & 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 ), , "106 :: " & 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 ), , "107 :: " & 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 ), , "108 :: " & 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 ), , "109 :: " & 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 ), , "110 :: " & 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 ), , "111 :: " & 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 ), , "112 :: " & 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 ), , "113 :: " & 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 ), , "114 :: " & 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, , "125 :: "
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 , , "179 :: " & 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, , "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 )
#########################################################################
>>> 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
#########################################################################
>>> 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 <<<
'*** v8.C *** 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
'*** 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 "123 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "124 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function DateiInhalt( DateiX )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileIn : Set FileIn = fso.OpenTextFile( DateiX, 1 )
Dim i
ReDim Preserve Zeile(i)
Do While Not ( FileIn.atEndOfStream )
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
i = i + 1
Loop
If UBound( Zeile ) < 1 Then
Zeile(i) = "Leerdatei"
End If
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 )
#########################################################################
>>> 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 )
#########################################################################
>>> 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.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(