http://dieseyer.de • all rights reserved • © 2011 v11.4
293 Skript-Dateien (*.vbs und *.hta) auf einen Blick:
#########################################################################
>>> 00-anfang-alle10s-trc32.vbs <<<
'*** v9.5 *** www.dieseyer.de ******************************
'
' Datei: 00-anfang-alle10s-trc32.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LetzteZeit, Tst
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( "-", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
WSHShell.Popup "= = = S T A R T = = =", 2, "031 :: " & WScript.ScriptName
Trace32Log "032 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "033 :: LogDatei: " & LogDatei, 1
Trace32Log "034 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "035 :: Angemeldeter User: " & WSHNet.UserName, 1
Do
Do ' Zeit "runden"
WScript.Sleep 200
Tst = now()
Tst = Mid( Tst, 1, Len( Tst ) - 1 ) ' für alle vollen 10s
' Tst = Mid( Tst, 1, Len( Tst ) - 2 ) ' für alle volle Minute
If Tst <> LetzteZeit Then LetzteZeit = Tst : Exit Do
Loop
Trace32Log "048 :: VBSmodTest: " & VBSmodTest & " - " & Tst, 1
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
If VBSmodTest > 10 Then Exit Do ' Ende nach 10 durchläufen
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "057 :: " & WScript.ScriptName
Trace32Log "058 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v?.? *** www.dieseyer.de ******************************
Function XXXX( YYYY, ZZZZ )
'***********************************************************
' On Error Resume Next
End Function ' XXXX( YYYY, ZZZZ )
'*** v5.A *** www.dieseyer.de ******************************
Sub VBSbeenden()
'***********************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "091 :: " & WScript.ScriptFullName & " existiert nicht!", 1
Trace32Log "092 :: " & WScript.ScriptFullName & " wird beendet . . . ", 1
Trace32Log "093 :: " & WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . ", 1
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "095 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de ******************************
Sub VBSneustart()
'***********************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "122 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "127 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "132 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 00-anfang-trc32.vbs <<<
'*** v?.? *** www.dieseyer.de ******************************
'
' Datei: AAAAA.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
' Call Trace32Log( "-", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
WSHShell.Popup "= = = S T A R T = = =", 2, "029 :: " & WScript.ScriptName
Trace32Log "030 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "031 :: LogDatei: " & LogDatei, 1
Trace32Log "032 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "033 :: Angemeldeter User: " & WSHNet.UserName, 1
Do
WScript.Sleep 1000 ' neue Sekunde abwarten
Do ' warten, bis eine neue Minute (mit xx:yy:00) anfängt
WScript.Sleep 20
If InStr( now(), ":00" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":10" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":20" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":30" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":40" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":50" ) = Len( now() ) - 2 Then Exit Do
Loop
Trace32Log "049 :: VBSmodTest: " & VBSmodTest, 1
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
If VBSmodTest > 10 Then Exit Do
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "056 :: " & WScript.ScriptName
Trace32Log "057 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v?.? *** www.dieseyer.de ******************************
Function XXXX( YYYY, ZZZZ )
'***********************************************************
' On Error Resume Next
End Function ' XXXX( YYYY, ZZZZ )
'*** v5.A *** www.dieseyer.de ******************************
Sub VBSbeenden()
'***********************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "090 :: " & WScript.ScriptFullName & " existiert nicht!", 1
Trace32Log "091 :: " & WScript.ScriptFullName & " wird beendet . . . ", 1
Trace32Log "092 :: " & WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . ", 1
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "094 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de ******************************
Sub VBSneustart()
'***********************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "121 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "126 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "131 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 00-anfang.vbs <<<
'*** v?.? *** www.dieseyer.de ******************************
'
' Datei: AAAAA.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest, VBSmodZahl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( "", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
WSHShell.Popup "= = = S T A R T = = =", 2, "028 :: " & WScript.ScriptName
Trace32Log "029 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "030 :: LogDatei: " & LogDatei, 1
Trace32Log "031 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "032 :: Angemeldeter User: " & WSHNet.UserName, 1
For i = 0 to Args.Count - 1 ' hole alle Argumente
Trace32Log "035 :: Argument " & i & ": >" & Args( i ) & "<", 1
Next
Do
WScript.Sleep 1000 ' neue Sekunde abwarten
Do ' warten, bis eine neue Minute (mit xx:yy:00) anfängt
WScript.Sleep 33 * VBSmodTest
If InStr( now(), ":00" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":10" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":20" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":30" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":40" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":50" ) = Len( now() ) - 2 Then Exit Do
Loop
Trace32Log "051 :: VBSmodTest: " & VBSmodTest, 1
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
If VBSmodTest > 10 Then Exit Do
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "058 :: " & WScript.ScriptName
Trace32Log "059 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v?.? *** www.dieseyer.de ******************************
Function XXXX( YYYY, ZZZZ )
'***********************************************************
' On Error Resume Next
End Function ' XXXX( YYYY, ZZZZ )
'*** v5.A *** www.dieseyer.de ******************************
Sub VBSbeenden()
'***********************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log( "092 :: " & WScript.ScriptFullName & " existiert nicht!" ), 1
Trace32Log( "093 :: " & WScript.ScriptFullName & " wird beendet . . . " ), 1
Trace32Log( "094 :: " & WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " ), 1
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "096 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de ******************************
Sub VBSneustart()
'***********************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "123 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "128 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "133 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v8.3 *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
Dim LogDateiX
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable LogDatei nicht außerhalb der Prozedur definiert
If Err.Number <> 0 Then LogDateiX = WScript.ScriptFullName & ".log"
On Error Goto 0
If LogTxt = "" Then ' eine neue .LOG-Datei wird erstellt, eine vorhandene überschrieben
Set FileOut = fso.OpenTextFile( LogDateiX, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDateiX, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Timer() & " " & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "256 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "257 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 100prozent.vbs <<<
'v4.3********************************************************
' File: 100prozent.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' "Erzeugt" 100% CPU-Last, bis es die Datei "ende.txt"
' gibt - das Skript sollte sich nicht auf einem Netz-
' laufwerk befinden.
'************************************************************
Option Explicit
Dim fso, i, n
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
MsgBox "Sobald es in dem Verzeichnis, in dem sich dieses Skript befindet," &vbCRLF & "die Datei ""ende.txt"" gibt, hört das Skript auf.", , WScript.ScriptName
i = 0
Do
i = i + 1
if i = 256*256*2 then n=1 ' : MsgBox i
if i > 256*256*2+256*4 then n=0 : i = 0 ' : MsgBox i
WScript.Sleep n
If fso.FileExists( "ende.txt" ) then Exit Do
Loop
MsgBox "Das waren wohl 100% CPU-Auslastung, oder?!", , WScript.ScriptName
#########################################################################
>>> 10ms.vbs <<<
'v5.A*****************************************************
Set Fso = WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss = WScript.CreateObject ( "WScript.Shell" )
Set Fso = WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss = WScript.CreateObject ( "WScript.Shell" )
' File: 10ms.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt die Zeit auf hundertstel Sekunden genau.
'
'***************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim ms : ms = ",00" & " Timer = " & Timer
If InStr( Timer, "," ) > 0 Then
' wenn Timer keine Nachkommastellen enthält
ms = Mid( Timer, InStr( Timer, "," ) ) & " Timer = " & Timer
End If
MsgBox "Jetzt ist es : " & Now() & ms, , "19 :: " & WScript.ScriptName
' alles in einer Zeile:
ms = now() : If InStr( Timer, "," ) > 0 Then ms = now() & Mid( Timer, InStr( Timer, "," ) )
MsgBox ms, , "24 :: " & WScript.ScriptName
#########################################################################
>>> 120minreboot.hta <<<
<head>
<!--
'v5.C***************************************************
' File: 120minReboot.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'*******************************************************
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SHOWINTASKBAR="no"
NAVIGABLE="no"
BORDER="none"
-->
<title>120minReboot</title>
<HTA:APPLICATION ID="oHTA"
SCROLL="No"
SHOWINTASKBAR="yes"
APPLICATIONNAME="120minReboot.hta"
>
<style type="text/css">
<!--
html, body { font-size:10pt; color:#E0C000; font-family:Verdana; font-weight:bold;
background:#1d2160;
}
a { font-size:100%; color:#FFFFFF; text-decoration:underline; }
a:active { color:red; }
a:link { color:#FFE000; }
a:visited { color:#E0C000; }
a:hover { color:red; }
a:active { color:#E0C000; }
-->
</style>
</head>
<script language="VBscript">
Const Dauer = "2:0:0"
Dim EndeZeit
'*******************************************************
Function ZeitAnzeige()
'*******************************************************
RestZeit = CDate( EndeZeit - Now() )
If Len( Hour( RestZeit ) ) = 1 Then Text = Text & "0"
Text = Text & Hour( RestZeit ) & ":"
If Len( Minute( RestZeit ) ) = 1 Then Text = Text & "0"
Text = Text & Minute( RestZeit ) & ":"
If Len( Second( RestZeit ) ) = 1 Then Text = Text & "0"
Text = Text & Second( RestZeit )
If CDate( EndeZeit ) > CDate( Now() ) Then Text = "==>> In " & Text & " startet dieser PC automatisch neu. <<=="
If not CDate( EndeZeit ) > CDate( Now() ) Then window.clearInterval( YesIntervall ) : self.close
document.all.RestZeitAnzeige.innerHTML = Text ' & "<br>" & EndeZeit
End Function ' ZeitAnzeige()
'*******************************************************
Function BeimLaden() ' ruft einige Routinen auf
'*******************************************************
call HTASize
EndeZeit = CDate( Now() + CDate( Dauer ) )
Call ZeitAnzeige
YesIntervall = window.setInterval( "ZeitAnzeige",1000 )
End Function ' BeimLaden
'*******************************************************
Sub HTASize()
'*******************************************************
' window.moveto Links, Oben
window.moveto 0, 0
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 640, 400
End Sub
'*******************************************************
Sub Auswahl()
'*******************************************************
' Call remoteShutdown( "" )
self.close
End Sub ' Auswahl()
'*******************************************************
Sub remoteShutdown( remotename ) ' 5.2 - http://dieseyer.de
'*******************************************************
' http://groups.google.de/groups?hl=de&lr=&newwindow=1&frame=right&th=43c55ccb528dbbc3&seekm=ebO58v50DHA.2480%40TK2MSFTNGP10.phx.gbl#link5
If remotename = "" Then remotename = CreateObject("WScript.Network").ComputerName
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
Dim wmi : Set wmi = GetObject( "winmgmts:{(RemoteShutdown)}!//" & remotename & "/root/cimv2" )
Dim objset : set objset = wmi.instancesof("win32_operatingsystem")
Dim obj, os
for each obj in objset
obj.security_.privileges.add 18, true
set os = obj : exit for
next
os.win32shutdown 6
End Sub ' remoteShutdown(remotename) 5.2 - http://dieseyer.de
</script>
<body onLoad="BeimLaden()" >
<center style="font-size:20pt; color:#E0C000; font-family:Verdana; font-weight:bold;">
Software Labor
</center>
<br>
Sehr geehrter Anwender,
<span style="font-size:4pt; "> <br> <br> </span>
nach dem die Installation der Software auf Ihren PC abgeschlossen ist,
sollte dieser PC neu gestartet werden.
<span style="font-size:4pt; "> <br> <br> </span>
Sobald dieses Fenster geschlossen wird, startet der PC SOFORT neu.
<ol>
<li>
Lesen Sie die
<a href="http://dieseyer.de/dse-wsh-mehr-hta.html" >HTA Infos</a>
aufmerksam durch.
<br>
Tip: Drucken Sie sich die
<a href="http://dieseyer.de/dse-wsh-mehr-hta.html" >HTA Infos</a>
aus.
</li>
<span style="font-size:4pt; "> <br> <br> </span>
<li>
Ist dieses Fenster geschlossen, wird Ihr Rechner automatisch neu gestartet.
</li>
<span style="font-size:4pt; "> <br> <br> </span>
<li>
Nach Abschluss des Neustarts können Sie wieder 'normal' arbeiten.
Die genaue Vorgehensweise entnehmen Sie bitte der
<a href="http://dieseyer.de/dse-wsh-mehr-hta.html" >HTA Infos</a>
</li>
</lo>
<br> <br>
<Center id=RestZeitAnzeige> </Center>
<span style="font-size:4pt; "> <br> <br> </span>
<span style="font-size:4pt; "> <br> <br> </span>
<Center>
<INPUT TYPE="button" value="Fenster schliessen und PC sofort neu starten" onClick="Auswahl()" >
</Center>
</body>
#########################################################################
>>> 1service_serviceentfernen.vbs <<<
'*** v9.7 *** www.dieseyer.de *******************************
'
' Datei: 1service_serviceentfernen.vbs
' aus vbsbeimsystemstart.vbs v8.4
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Const Dienst1 = "1Service" ' DienstName auf dem ZielPC
Dim ZielPC
' Dim ZielVerz, ZielWinDir, ZielDatei, Txt, Tst
' LOG-Datei-Namen festlegen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim LogDatei
LogDatei = ""
Trace32Log "Starte: """ & ZielPC & """ " , 1 ' LOG-Datei ist VBS-Name
' Dim aktVerz : aktVerz = WshShell.ExpandEnvironmentStrings("%WinDir%") & "\system32\CCM\Inst.LOG\"
Dim AktVerz : AktVerz = Replace( WScript.ScriptFullName, WScript.ScriptName, "" ) ' mit "\" am Ende!!!
' If InStr( VBSStart, "\" ) > 1 Then AktVerz = Mid( VBSStart, 1, InStrRev( VBSStart, "\" ) )
LogDatei = WScript.ScriptFullName
LogDatei = Mid( LogDatei, 1, InStrRev( LogDatei, "." ) - 1 ) ' alles bis zum letzten Punkt
LogDatei = LogDatei & "_" & ZielPC & ".log" ' LogDatei enthält jetzt PCNamen
LogDatei = AktVerz & fso.GetBaseName( WScript.ScriptFullName )& "_" & ZielPC & ".log" ' LogDatei enthält jetzt PCNamen
' Trace32Log "-", 0 ' erstellt neue LogDatei (wegen 0)
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
Trace32Log "044 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "045 :: LogDatei: " & LogDatei, 1
Trace32Log "046 :: AktVerz: " & AktVerz, 1
Trace32Log "047 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "048 :: Angemeldeter User: " & WSHNet.UserName, 1
Trace32Log "049 :: ZielPC: " & ZielPC, 1
Call ServiceEntfernen( ".", Dienst1 )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "062 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
LogDatei = "" : Trace32Log "Abgearbeitet: """ & ZielPC & """ " , 1 ' LOG-Datei ist VBS-Name
WScript.Quit
'*********************************************************
Sub ServiceEntfernen( PC, Dienst )
'*********************************************************
Trace32Log "071 :: START: Sub ServiceEntfernen( """ & PC & """, """ & Dienst & """ )", 1
Dim objWMIService, colServices, objService
Dim Txt
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colServices
objService.StopService() : Trace32Log "079 :: Stopanforderung . . . ", 1
WScript.Sleep 3*1000
objService.Delete() : Trace32Log "081 :: Löschanforderung . . . ", 1
Next
Set objWMIService = nothing
Set colServices = nothing
Txt = ""
' Test, ob Dienst vorhanden ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\" & PC & "\root\cimv2")
Set colServices = objWMIService.ExecQuery ("Select * From Win32_Service" )
For Each objService in colServices
If objService.DisplayName = Dienst Then Txt = """" & objService.DisplayName & """ (" & objService.State & ")"
Next
Txt = "Der Dienst """ & Dienst & """ wurde von """ & PC & """ entfernt."
' If Len( Txt ) > 5 Then MsgBox now() & vbCRLF & Txt , , "095 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "096 :: " & Txt, 1
If Len( Txt ) > 5 Then Exit Sub
Txt = "FEHLER: Der Dienst """ & Dienst & """ konnte nicht von """ & PC & """ entfernt werden."
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "100 :: " & WScript.ScriptName
Trace32Log "101 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "103 :: " & "= = = E N D E = = ="
WScript.Quit
End Sub ' ServiceEntfernen( PC, Dienst )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 1und1_htmlstatistic_nach_html.vbs <<<
'*** v10.3 *** www.dieseyer.de ****************************
'
' Datei: 1und1_htmlstatistic_nach_html.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ist der Provider der eigenen Site 1&1, befindet sich im
' Verzeichnis ftp://[site]/logs/traffic.html
' die Zugriffs-Statistik der letzten 12 Monate.
' Sind diese Dateien über mehrere Jahre in einem Verzeichnis
' nach dem Muster "[Jahr]-[Monat].html" gespeichert, erstellt
' dieses Skript eine Kurzübersicht als HTML-Datei - vergl.
' http://dieseyer.de/dse-statistic.html
'
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Dim QuellVerz : QuellVerz = "D:\dieseyer.xxx\dieseyer.html"
Const Zoom = 1.75
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( "", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log "033 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "034 :: LogDatei: " & LogDatei, 1
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "036 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim Txt, Tst, Tyt, i, arrDaten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDaten = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "044 :: UBound( arrDaten ): " & UBound( arrDaten ), 1
' arrayZeigen( arrDaten )
ReDim Preserve Zeile( 0 )
For i = LBound( arrDaten ) to UBound( arrDaten )
arrDaten( i ) = DatumUndAnzahl( arrDaten( i ) )
Next
' arrayZeigen( arrDaten )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' QuickSort arrDaten, LBound( arrDaten ), UBound( arrDaten )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDaten )
Dim FileOut
Set FileOut = fso.OpenTextFile( WSCript.ScriptFullName & ".html", 2, True ) ' 2 => neue Datei; 8 => Datei erweitern
FileOut.WriteLine "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">"
FileOut.WriteLine "<html>"
FileOut.WriteLine "<head>"
FileOut.WriteLine "<meta http-equiv=""content-type"" content=""text/html; charset=windows-1250"">"
FileOut.WriteLine "<title></title>"
FileOut.WriteLine "</head>"
FileOut.WriteLine "<body>"
' FileOut.WriteLine "<pre><tt>"
For i = UBound( arrDaten ) to LBound( arrDaten ) Step -1 ' beginnend mit den neusten
' For i = LBound( arrDaten ) to UBound( arrDaten ) ' beginnend mit den ältesten
Txt = arrDaten(i)
If not Left( Txt, 15 ) = Left( Tst, 15 ) Then
' FileOut.WriteLine Mid( Txt, 17 ) ' & "<br>"
' FileOut.WriteLine Mid( Txt, 17 ) & vbTab & String( CInt( Mid( Txt, InStr( Txt, vbTab ) + 1 ) ), "|" )
' FileOut.WriteLine Mid( Txt, 17 ) & vbTab & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17 ), "#" )
' FileOut.WriteLine "<tt>" & Mid( Txt, 17 ) & " </tt>" & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17 ), "<b>|</b>" ) & "<br>"
FileOut.WriteLine "<tt>" & Mid( Txt, 17 ) & " </tt><b>" & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17, 2 ) * Zoom , "|" ) & "</b><br>"
' FileOut.WriteLine "<tt>" & Mid( Txt, 17 ) & " </tt><b>" & String( ( ( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17, 2) - 30 ) * 4 ), "|" ) & "</b><br>"
Tst = Txt
Else
arrDaten(i) = ""
End If
Next
' FileOut.WriteLine "</tt></pre>"
FileOut.WriteLine "</body>"
FileOut.WriteLine "</html>"
FileOut.Close
Set FileOut = nothing
' ArrayZeigen( arrDaten )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
Trace32Log "099 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
WScript.Quit
'*** v9.4 *** www.dieseyer.de ****************************
Function DatumUndAnzahl( Datei )
'*********************************************************
' Beispiel-Zeile:
' <!-- 2009-02-28 23.933 826 23.933 826 0.000 0 0.000 0 0.000 0 -->
' Interressant ist nur die Zahl der HTTP-Zugriffe (hier 826);
' diese befindet sich hinter dem 3. Leerschritt
' Die Prozedur gibt eine Zeichenkette zurückmit Monat und
' Anzahl der Zugriffe:
' "1.2.2009" & vbTab & 2.345
' alle Zeilen lesen und auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim FileIn : Set FileIn = FSO.OpenTextFile(Datei, 1 )
Dim Datum, Summe, Txt, Tst, i
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Txt = FileIn.Readline
If InStr( Txt, "<!-- 20" ) = 1 AND InStr( Txt, "-->" ) > 50 Then
If Datum = "" Then
' MsgBox Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "125 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 1 Then Datum = Left( txt, 15 ) & vbTab & "Jan. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "126 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 2 Then Datum = Left( txt, 15 ) & vbTab & "Feb. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "127 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 3 Then Datum = Left( txt, 15 ) & vbTab & "Mrz. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "128 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 4 Then Datum = Left( txt, 15 ) & vbTab & "Apr. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "129 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 5 Then Datum = Left( txt, 15 ) & vbTab & "Mai " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "130 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 6 Then Datum = Left( txt, 15 ) & vbTab & "Jun. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "131 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 7 Then Datum = Left( txt, 15 ) & vbTab & "Jul. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "132 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 8 Then Datum = Left( txt, 15 ) & vbTab & "Aug. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "133 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 9 Then Datum = Left( txt, 15 ) & vbTab & "Sep. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "134 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 10 Then Datum = Left( txt, 15 ) & vbTab & "Okt. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "135 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 11 Then Datum = Left( txt, 15 ) & vbTab & "Nov. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "136 :: " & CInt( Mid( Txt, 11, 2 ) )
If CInT( Mid( Txt, 11, 2 ) ) = 12 Then Datum = Left( txt, 15 ) & vbTab & "Dez. " & Mid( Txt, 6, 4 ) ' : MsgBox Datum & vbTab & Left( txt, 15 ) & vbTab & Mid( Txt, 6, 4 ), , "137 :: " & CInt( Mid( Txt, 11, 2 ) )
End If
If Datum = "" Then Datum = Mid( Txt, 6, 10 ) & vbTab & CDate( Mid( Txt, 14, 2 ) & "." & Mid( Txt, 11, 2 ) & "." & Mid( Txt, 6, 4 ) )
If Datum = "" Then Datum = CDate( "1." & Mid( Txt, 11, 2 ) & "." & Mid( Txt, 6, 4 ) )
Tst = Split( Txt, " ", -1, 1)
Summe = Summe + CLng( Tst( 3 ) )
End If
Loop
FileIn.Close
Set FileIn = nothing
' MsgBox Datum & vbTab & Summe & vbCRLF & "Datei:" & vbTab & Datei, , "148 :: "
DatumUndAnzahl = Datum & vbTab & Round( Summe / 1000, 0 )
DatumUndAnzahl = Datum & vbTab & CSng( Summe )
End Function ' DatumUndAnzahl( Datei )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "203 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Dim i, oFolder, oFiles, DateiX
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolder = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v8.3 *** www.dieseyer.de *******************************
Function QuickSort( vntArray, intVon, intBis )
'************************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim i, j
Dim vntTestWert, intMitte, vntTemp
If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis
Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop
Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop
If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If
End Function ' QuickSort( vntArray, intVon, intBis )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "378 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "379 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> 2-5mal-input-ds.vbs <<<
'v4.B***************************************************
' File: 2-5mal-input.vbs
' Autor: W.Schmelz (verändert: dieseyer@gmx.de)
' http://source-center.de/forum/showthread.php?t=1738
'
' http://dieseyer.de
'
' zerlegt / extrahiert aus der Eingabe in eine
' InputBox mehrere Eingaben.
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, Txt1, Txt2, Txt3, Txt4, Txt5
Dim Eingabe, i, Tst
Dim Sym : Sym ="#" ' Trennsymbol " # " evtl. anpassen
Dim Titel : Titel =" Input - Box mit 2 bis 5 Einträgen "
' Streichen oder Hinzufügen einer Schleife am Ende ändert Höchstzahl der Einträge !
'*******************************************************
Txt = Txt & "Bitte mit Abtrennung durch " & Sym & " eintragen" & VbCRLF & VbCRLF
Txt = Txt & "und dabei auf die Reihenfolge achten!" & VbCRLF & VbCRLF & VbCRLF
Txt = Txt & "1) Die Pers. Nr. z. B. A 7770007700" & VbCRLF & VbCRLF
Txt = Txt & "2) Die Telefonvorwahl z. B. 02374" & VbCRLF & VbCRLF
Txt = Txt & "3) Die Telefon - Nr. z. B. 77777" & VbCRLF & VbCRLF
Txt = Txt & "4) Name : Schulze - Bochum, Karl - Heinz" & VbCRLF & VbCRLF
Txt = Txt & "4) und noch : . . . " & VbCRLF & VbCRLF & VbCRLF
Txt = Txt & "Pers.Nr. " & Sym & " Vorwahl " & Sym & " Telefon " & Sym & " Name " & Sym & " Sonstiges"
Eingabe = " A788 # 0711 # 540367# Dseyer#doof " ' zum Testen
Eingabe = InputBox( VbCRLF & Txt & VbCRLF, Titel, Eingabe )
If Eingabe="" then WScript.Quit
If not Right( Eingabe, 1 ) = Sym then Eingabe = Eingabe & Sym ' Falls Symbol rechts vergessen!
If Left( Eingabe, 1 ) = Sym then Eingabe = Mid( Eingabe, 2 ) ' Falls Symbol links!
' Die Eingabenfolge wird gemäß den " # " in Abschnitte zerlegt
' und die Teile als Variablen " Txti " definiert
Txt = ""
Tst = Split( Eingabe, Sym ) ' Eingabe aufteilen und in Array Tst() ablegen
for i = LBound( Tst ) to UBound( Tst ) ' jeden Teil auswerten
If Left( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 2 )
If Left( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 2 )
If Right( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 1, Len( Tst(i) ) -1 )
If Right( Tst(i), 1 ) = " " Then Tst(i) = Mid( Tst(i), 1, Len( Tst(i) ) -1 )
' MsgBox i & vbTab & "==>" & Tst(i) & "<==" , , "Txt" ' zum Testen
if i = 0 Then Txt1 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 1 Then Txt2 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 2 Then Txt3 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 3 Then Txt4 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
if i = 4 Then Txt5 = Tst(i) : Txt = Txt & i & vbTab & Tst(i) & vbCRLF
next
' MsgBox Txt, , "Txt" ' zum Testen
Ende ' Sub - Aufruf
WScript.Quit
'**************************************************************
Sub Ende
'**************************************************************
' Kontrollmeldung:
Txt=VbCRLF&VbCRLF
Txt=Txt&"1) Die Pers. Nr. ist "& Txt1 &VbCRLF&VbCRLF
Txt=Txt&"2) Die Telefonvorwahl ist "& Txt2 &VbCRLF&VbCRLF
Txt=Txt&"3) Die Telefon - Nr. ist "& Txt3 &VbCRLF&VbCRLF
Txt=Txt&"4) Name ist "& Txt4 &VbCRLF&VbCRLF
Txt=Txt&"5) und noch ist "& Txt5 &VbCRLF&VbCRLF
MsgBox Txt,,Titel
End Sub ' Ende
#########################################################################
>>> 2-5mal-input.vbs <<<
'v4.B***************************************************
' File: 2-5mal-input.vbs
' Autor: W.Schmelz
' http://source-center.de/forum/showthread.php?t=1738
'
' http://dieseyer.de
'
' zerlegt / extrahiert aus der Eingabe in eine
' InputBox mehrere Eingaben.
'*******************************************************
Option Explicit
Dim Txt, Txt1, Txt2, Txt3, Txt4, Txt5
Dim Laenge, Sym, i
Dim Zahl1, Zahl2, Zahl3, Zahl4, Zahl5
Dim Rechts, Rechts1, Rechts2, Rechts3, Rechts4, Rechts5
Dim Links, Links1, Links2, Links3, Links4, Links5
Dim Eingabe, Eingabe1, Eingabe2, Eingabe3, Eingabe4, Eingabe5
Dim Titel : Titel =" Input - Box mit 2 bis 5 Einträgen "
' Streichen oder Hinzufügen einer Schleife am Ende ändert Höchstzahl der Einträge !
' ************************************************
Txt=Txt&"Bitte mit Abtrennung durch # eintragen"&VbCRLF&VbCRLF
Txt=Txt&"und dabei auf die Reihenfolge achten !"&VbCRLF&VbCRLF&VbCRLF
Txt=Txt&"1) Die Pers. Nr. z. B. A 7770007700"&VbCRLF&VbCRLF
Txt=Txt&"2) Die Telefonvorwahl z. B. 02374"&VbCRLF&VbCRLF
Txt=Txt&"3) Die Telefon - Nr. z. B. 77777"&VbCRLF&VbCRLF
Txt=Txt&"4) Name : Schulze - Bochum, Karl - Heinz"&VbCRLF&VbCRLF
Txt=Txt&"4) und noch : . . . "&VbCRLF&VbCRLF&VbCRLF
Txt=Txt&" Pers.Nr. # Vorwahl # Telefon # Name # Sonst "
Sym="#" ' Trennsymbol " # " evtl. sinngemäß ändern!
' *****************************************
Eingabe=InputBox (VbCRLF&Txt&VbCRLF,Titel,Eingabe)
If Eingabe="" then WScript.Quit
If not (Right(Eingabe,1)=Sym) then Eingabe=Eingabe&Sym ' Falls Symbol rechts vergessen!
If Left(Eingabe,1)=Sym then Eingabe=Mid(Eingabe,2) ' Falls Symbol links!
Eingabe1=Eingabe
Laenge=Len(Eingabe1)
' Die Eingabenfolge wird gemäß den " # " in Abschnitte zerlegt
' und die Teile als Variablen " Txti " definiert
Zahl1=0
i=1
Do until Rechts=Sym
Links=Left(Eingabe1,i)
Rechts=Right(Links,1)
i=i+1
Zahl1=Zahl1 +1 ' Zahl1 ist Länge der 1. Sequenz mit dem " # "
Loop
Txt1=Left(Links,Zahl1 -1)
Eingabe2=Right(Eingabe1,Laenge-Zahl1) ' Neufestlegung
If Eingabe2="" then Ende
Zahl2=0
i=1
Do until Rechts2=Sym
Links2=Left(Eingabe2,i)
Rechts2=Right(Links2,1)
i=i+1
Zahl2=Zahl2 +1
Loop
Txt2=Left(Links2,Zahl2 -1)
Eingabe3=Right(Eingabe2,Laenge-Zahl1-Zahl2)
If Eingabe3="" then Ende
Zahl3=0
i=1
Do until Rechts3=Sym
Links3=Left(Eingabe3,i)
Rechts3=Right(Links3,1)
i=i+1
Zahl3=Zahl3 +1
Loop
Txt3=Left(Links3,Zahl3 -1)
Eingabe4=Right(Eingabe3,Laenge-Zahl1-Zahl2-Zahl3)
If Eingabe4="" then Ende
Zahl4=0
i=1
Do until Rechts4=Sym
Links4=Left(Eingabe4,i)
Rechts4=Right(Links4,1)
i=i+1
Zahl4=Zahl4 +1
Loop
Txt4=Left(Links4,Zahl4 -1)
Eingabe5=Right(Eingabe4,Laenge-Zahl1-Zahl2-Zahl3-Zahl4)
If Eingabe5="" then Ende
Zahl5=0
i=1
Do until Rechts5=Sym
Links5=Left(Eingabe5,i)
Rechts5=Right(Links5,1)
i=i+1
Zahl5=Zahl5 +1
Loop
Txt5=Left(Links5,Zahl5 -1)
Ende ' Sub - Aufruf
WScript.Quit
'**************************************************************
Sub Ende
'**************************************************************
' Kontrollmeldung:
Txt=VbCRLF&VbCRLF
Txt=Txt&"1) Die Pers. Nr. ist "& Txt1 &VbCRLF&VbCRLF
Txt=Txt&"2) Die Telefonvorwahl ist "& Txt2 &VbCRLF&VbCRLF
Txt=Txt&"3) Die Telefon - Nr. ist "& Txt3 &VbCRLF&VbCRLF
Txt=Txt&"4) Name ist "& Txt4 &VbCRLF&VbCRLF
Txt=Txt&"5) und noch ist "& Txt5 &VbCRLF&VbCRLF
MsgBox Txt,,Titel
End Sub ' Ende
#########################################################################
>>> 7s-aufeingabewarten.vbs <<<
'*** v9.6 *** www.dieseyer.de *******************************
'
' Datei: 7s-AufEingabeWarten.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WshShell, Tst
Set WshShell = WScript.CreateObject("WScript.Shell")
Tst = WshShell.Popup("Möchten Sie vom Skript Ihr Alter in Tagen wissen?" & vbCRLF & vbCRLF & "Wenn nicht, beendet sich das Skript in 7s", 7, WScript.ScriptName, 4 + 32)
If not Tst = vbYes Then
MsgBox "Das ist das Ende . . .", vbInformation, WScript.ScriptName
WScript.Quit
End If
Tst = InputBox( "Bitte geben Sie Ihren Geburtstag ein:", WScript.Scriptname, "01.01.1999" )
If Tst = "" Then
MsgBox "Das war keine gültige Eingabe!" & vbCRLF & vbCRLF & "Das ist das Ende . . .", vbInformation, WScript.ScriptName
WScript.Quit
End If
MsgBox "Jeder, der am " & Tst & " geboren wurde, ist heute " & DateDiff( "d", CDate( Tst ), now() ) & " Tage alt.", , WScript.ScriptName
#########################################################################
>>> AcronisAlteTibEntfernen.vbs <<<
'*** v10.8 *** www.dieseyer.de *****************************
' Datei: AcronisAlteTibEntfernen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die anzugebebene Datei wird nicht gelöscht, aber ALLE
' Dateien in dem selben Verzeichnis mit der selben Datei-
' Erweiterung (Extension), die ein bestimmtes Alter haben,
' werden beim Skriptaufruf gelöscht!
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Const DateiBleibt = "\\benz-tspro\backup\acronis\benz-ts01\BENZ-TS01.tib"
Const Alter = 99 ' Dateien, die seit xxx Tagen nicht geändert wurden - außer DateiBleibt
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Const VielLog = "-Ja"
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( " ", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup vbTab & "= = = S T A R T = = =", 2, "037 :: " & WScript.ScriptName, vbInformation
Trace32Log "038 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "039 :: LogDatei: " & LogDatei, 1
Trace32Log "040 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "041 :: Angemeldeter User: " & WSHNet.UserName, 1
AcronisAlteTibEntfernen DateiBleibt, Alter
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.Popup vbTab & "= = = E N D E = = =", 2, "046 :: " & WScript.ScriptName, 4096 + vbInformation
Trace32Log "047 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log " ", 1
Wscript.Quit
'*** v10.8 *** www.dieseyer.de *****************************
Function AcronisAlteTibEntfernen( DateiBleibt, Alter )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Verz, DateiErw, oFiles, Datei, DateiTst, Txt, Tst, errTst, i, n
i = 0 : n = 0
Trace32Log "063 :: Alte Dateien sollen gelöscht werden - min. Alter der zu löschenden Dateien: " & Alter & "d", 1
Trace32Log "064 :: Alte Dateien sollen gelöscht werden - Änderungsdatum der Dateien am oder vor dem " & FormatDateTime( now() - Alter, 2) & " - aktuelles Datum: " & Date(), 1
If not fso.FileExists( DateiBleibt ) then
WSHShell.Popup vbTab & "Datei / Verzeichnis existiert nicht:" & vbCRLF & vbCRLF & DateiBleibt, 5, "067 :: " & WScript.ScriptName, 4096 + vbCritical
Trace32Log "068 :: Datei / Verzeichnis existiert nicht: " & DateiBleibt, 3
Exit Function
End If
Trace32Log "071 :: Alte Dateien sollen gelöscht werden - außer: " & DateiBleibt, 1
Verz = fso.GetParentFolderName( DateiBleibt )
If not fso.FolderExists( Verz ) then
WSHShell.Popup vbTab & "Verzeichnis existiert nicht:" & vbCRLF & vbCRLF & Verz, 5, "075 :: " & WScript.ScriptName, 4096 + vbCritical
Trace32Log "076 :: Verzeichnis existiert nicht: " & Verz, 3
Exit Function
End If
Trace32Log "079 :: Alte Dateien sollen gelöscht werden - Verzeichnis: " & Verz, 1
DateiErw = UCase( fso.GetExtensionName( DateiBleibt ) )
Trace32Log "082 :: Alte Dateien sollen gelöscht werden - Dateierweiterung (Extension): " & DateiErw, 1
Trace32Log "084 :: ", 1
Set oFiles = fso.GetFolder( Verz ).Files
For Each Datei In oFiles
DateiTst = "OK"
' Trace32Log "090 :: Datei wird geprüft: " & Datei.Path, 1
' Trace32Log "091 :: Letzte Dateiänderung: " & Datei.DateLastModified, 1
' Trace32Log "092 :: min. ALter: " & FormatDateTime( now() - Alter, 2) & " - " & Alter & "d", 1
' Trace32Log "093 :: ALtersunterschied zu heute: " & DateDiff( "d" , Datei.DateLastModified, Date() ) & "d", 1
' Trace32Log "094 :: Daeierweiterung: " & UCase( fso.GetExtensionName( Datei.Path ) ), 1
' MsgBox Datei.GetExtensionName, , "096 :: " : WScript.Quit
If VielLog = "Ja" Then Trace32Log "098 :: Datei wird geprüft: " & Datei, 1
If not UCase( fso.GetExtensionName( Datei.Name) ) = DateiErw Then DateiTst = "-OK" : If VielLog = "Ja" Then Trace32Log "100 :: Dateierweiterung stimmt nicht: " & UCase( fso.GetExtensionName( Datei ) ), 1
If DateDiff( "d" , Datei.DateLastModified, Date() ) < Alter Then DateiTst = "-OK" : If VielLog = "Ja" Then Trace32Log "102 :: Datei ist nicht alt genug - Alter: " & DateDiff( "d" , Datei.DateLastModified, Date() ), 1
If UCase( Datei ) = UCase( DateiBleibt ) Then DateiTst = "-OK" : Trace32Log "104 :: Datei soll bleiben (Ausnahme-Datei): " & Datei, 2
If not DateiTst = "OK" Then
If VielLog = "Ja" Then Trace32Log "107 :: Datei wird nicht gelöscht: " & Datei, 1
Else
Txt = Datei.path ' nach dem Löschen von Datei.Path ist, fehlt Datei.Path
Tst = Datei.DateLastModified & " = " & DateDiff( "d" , Datei.DateLastModified, Date() ) & "d alt."
If VielLog = "Ja" Then Trace32Log "111 :: Datei soll gelöscht werden: " & Txt, 1
On Error Resume Next
fso.DeleteFile Txt, True
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
if Len( errTst ) < 5 Then
Trace32Log "119 :: Datei ist Gelöscht: " & Txt & " - Dateidatum: " & Tst, 1
i = i + 1
Else
Trace32Log "122 :: Datei nicht löschbar: " & Txt & " - " & errTst, 3
n = n + 1
End if
End if
Next
Set oFiles = nothing
Set fso = nothing
Trace32Log "131 :: ", 1
Trace32Log "132 :: " & i & " Dateien sind gelöscht.", 1
If n > 0 Then Trace32Log "133 :: " & n & " Dateien konnten nicht gelöscht werden - wegen Fehler.", 2
Trace32Log "134 :: ", 1
End Function ' AcronisAlteTibEntfernen( DateiBleibt, Alter )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "223 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "224 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> ad-pcliste.vbs <<<
'*** v9.7 *** www.dieseyer.de *******************************
'
' Datei: ad-pcliste.vbs
' Autor: xxx.dexter.xxx@googlemail.com
' Auf: www.dieseyer.de
'
' http://www.source-center.de/forum/showthread.php?p=79678
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim arrPCAlle 'Zeichenketten-Array
Dim strPC 'Zeichenkette
Dim ErrorOccurred 'Boolesch
ErrorOccurred = FALSE
arrPCAlle = PCListePlusADScan("ou=laptops,OU=domain hardware")
arrPCAlle = PCListePlusADScan("ou=E010,ou=P4SWL,OU=Clients")
If Not ErrorOccurred Then
For Each strPC in arrPCAlle
Txt = Txt & strPC & vbCRLF
next
End If
MsgBox Txt, , "021 :: " & WScript.ScriptName
WScript.Quit
'*** v9.7 *** www.dieseyer.de *******************************
Function PCListePlusADScan( Argument )
'************************************************************
' Autor: xxx.dexter.xxx@googlemail.com
' Beschreibung ....: Liefert die Domänencomputer in einem Array zurück. STANDARD: Gesamte Domäne
' Parameter .......: Argument(Syntax <[OU]|[Suchbereich]>) als Zeichenkette
' Rückgabewert ....: Computer als Zeichenketten-Array
'*** Konstanten
Const INDEX_OU = 0
Const INDEX_SCOPE = 1
Const ADS_SCOPE_BASE = 0
Const ADS_SCOPE_ONELEVEL = 1
Const ADS_SCOPE_SUBTREE = 2
'*** Variabeln
Dim RootDSE 'RootDSE-Objekt
Dim ADObject 'Active Directory-Object
Dim AdoCnn 'AdoConnection-Objekt
Dim AdoCmd 'AdoCommand-Objekt
Dim AdoRst 'AdoRecordSet-Objekt
Dim OUDetected 'Boolesch
Dim ScopeDetected 'Boolesch
Dim ValidParameter 'Boolesch
Dim ADsPath 'Zeichenkette
Dim SearchScope 'Zeichenkette
Dim Arguments 'Zeichenketten-Array
Dim Computer() 'Zeichenketten-Array
Dim ErrorNumber 'Ganzahl
Dim i 'Ganzzahl
'*** Bindung an den Stamm der Verzeichnisses aufbauen
ON ERROR RESUME NEXT
Set RootDSE = GetObject("ldap://rootDSE")
If Err.Number <> 0 Then
ErrorOccurred = True
ErrorNumber = Err.Number
Err.Clear
On Error GoTo 0
MsgBox ADSIFehler(ErrorNumber), , "067 :: " & WScript.ScriptName
EXIT FUNCTION
End If
'*** ENDREGION
'*** Variabeln initialisieren
ADsPath = UCase("LDAP://" & RootDSE.Get("rootDomainNamingContext"))
SearchScope = ADS_SCOPE_SUBTREE
OUDetected = FALSE
ScopeDetected = FALSE
ValidParameter = FALSE
'*** ENDREGION
'*** Visual Basic Skript unterstützt keine optionalen Parameter!
Arguments = Split(Argument, "|")
Select Case UBound(Arguments)
Case -1
OUDetected = TRUE
ScopeDetected = TRUE
ValidParameter = TRUE
Case 0
OUDetected = TRUE
ValidParameter = TRUE
Case 1
OUDetected = TRUE
ScopeDetected = TRUE
ValidParameter = TRUE
Case Else
ErrorOccurred = True
MsgBox "Falsche Anzahlt von Argumenten wurde übergeben. " & Join(Arguments), , "096 :: " & WScript.ScriptName
EXit Function
End Select
If ValidParameter Then
If OUDetected Then
If Not Arguments(INDEX_OU) = "" Then
ADsPath = UCase("LDAP://" & Arguments(INDEX_OU) & "," & RootDSE.Get("rootDomainNamingContext"))
End If
End If
If ScopeDetected Then
If Not Arguments(INDEX_SCOPE) = "" Then
Select Case LCase(Arguments(INDEX_SCOPE))
Case "base"
SearchScope = ADS_SCOPE_BASE
Case "onelevel"
SearchScope = ADS_SCOPE_ONELEVEL
Case Else
ErrorOccurred = True
MsgBox "Der Suchbereich '" & Arguments(INDEX_SCOPE) & "' wird nicht unterstützt!", , "115 :: " & WScript.ScriptName
Exit Function
End Select
End If
End If
End If
'*** ENDREGION
'*** Die Gültigkeit des ADsPfades überprüfen.
ON ERROR RESUME NEXT
Set ADObject = GetObject(ADsPath)
If Err.Number <> 0 Then
MsgBox "Der Pfad '" & ADsPath & "' ist ungültig!", , "127 :: " & WScript.ScriptName
ErrorOccurred = True
ErrorNumber = Err.Number
Err.Clear
ON ERROR GOTO 0
MsgBox ADSIFehler(ErrorNumber), , "132 :: " & WScript.ScriptName
EXIT FUNCTION
End If
Set ADObject = Nothing
'*** ENDREGION
'*** Nach AD-Objekte mit der Abfragetechnologie Active Data Object suchen.
Set AdoCnn = CreateObject("ADODB.Connection")
AdoCnn.Provider = "ADsDSOObject"
AdoCnn.Open "Active Directory Provider"
Set AdoCmd = CreateObject("ADODB.Command")
Set AdoCmd.ActiveConnection = AdoCnn
With AdoCmd
.CommandText = "SELECT Name FROM '" & ADsPath & "' WHERE objectClass='computer'"
.Properties("Page Size") = 1000
.Properties("Searchscope") = SearchScope
.Properties("Sort On") = "Name"
Set AdoRst = .Execute
End With
'*** ENDREGION
'*** Array für die RÜckgabe aufbereiten
i = 0
Do Until AdoRst.EOF
ReDim Preserve Computer(i)
Computer(i) = AdoRst.Fields("Name").Value
AdoRst.MoveNext
i = i + 1
Loop
'*** ENDREGION
PCListePlusADScan = Computer
End Function ' PCListePlusADScan( Argument )
'*** v9.7 *** www.dieseyer.de *******************************
Function ADSIFehler( ByVal ErrorCode )
'************************************************************
' Autor: xxx.dexter.xxx@googlemail.com
' Beschreibung ....: Wertet die Fehlernummer aus
' Parameter .......: Int Errorcode
' Rückgabewert ....: Fehlerbeschreibung Als Zeichenkette
' Notiz ...........: Allgemeine ADSI-Fehler (http://msdn.microsoft.com/en-us/libr...40(VS.85).aspx)
' LDAP-Fehler für ADSI (http://msdn.microsoft.com/en-us/libr...28(VS.85).aspx)
' LDAP-Fehler für ADSI 2.0 (http://msdn.microsoft.com/en-us/libr...30(VS.85).aspx)
Dim AdsErrorDict 'Dictionary-Objekt
Dim HexErrorCode 'Hex-Zahl
Dim ErrorDescription 'ZeichenKette
Dim ErrorMessage 'Zeichenkette
Set ADsErrorDict = CreateObject("Scripting.Dictionary")
HexErrorCode = Hex(ErrorCode)
ADsErrorDict.Add "800401E4", "INVALID_SYNTAX"
ADsErrorDict.Add "80005000", "E_ADS_BAD_PATHNAME"
ADsErrorDict.Add "80005001", "E_ADS_INVALID_DOMAIN_OBJECT"
ADsErrorDict.Add "80070005", "E_ADS_INSUFFICIENT_RIGHTS"
ADsErrorDict.Add "80070035", "NETWORKPATH_NOT_FOUND"
ADsErrorDict.Add "8007052E", "LDAP_INVALID_CREDENTIALS"
ADsErrorDict.Add "8007054B", "LDAP_DOMAIN_DOESNT_EXIST"
ADsErrorDict.Add "80072020", "LDAP_OPERATIONS_ERROR"
ADsErrorDict.Add "80072030", "LDAP_NOT_SUCH_OBJECT"
Select Case AdsErrorDict(HexErrorCode)
Case "INVALID_SYNTAX"
ErrorDescription = "Ungültiger Syntax!"
Case "E_ADS_BAD_PATHNAME"
ErrorDescription = "Ungültiger ADSI-Pfadnamen!"
Case "E_ADS_INVALID_DOMAIN_OBJECT"
ErrorDescription = "Unbekanntes ADSI-Domänenobjekt!"
Case "E_ADS_INSUFFICIENT_RIGHTS"
ErrorDescription = "Nicht ausreichende Zugriffsrechte!"
Case "NETWORKPATH_NOT_FOUND"
ErrorDescription = "Netzwerkpfad wurde nicht gefunden!"
Case "LDAP_INVALID_CREDENTIALS"
ErrorDescription = "Ungültige Anmeldeinformationen!"
Case "LDAP_DOMAIN_DOESNT_EXIST"
ErrorDescription = "Domäne nicht verfügbar!"
Case "LDAP_OPERATIONS_ERROR"
ErrorDescription = "Fehler bei der Operation aufgetreten!"
Case "LDAP_NOT_SUCH_OBJECT"
ErrorDescription = "Objekt ist nicht vorhanden!"
Case Else
ErrorDescription = "Unbekannter Fehler!"
End Select
ErrorMessage = "ADSI-Fehler" & vbCrLf & _
"Beschreibung: " & vbTab & ErrorDescription & vbCrLf & _
"Nr. (dez): " & vbTab & ErrorCode & vbCrLf & _
"Nr. (hex): " & vbTab & "0x" & HexErrorCode & vbCrLf
ADSIFehler = ErrorMessage
End Function ' ADSIFehler( ByVal ErrorCode )
#########################################################################
>>> adminstart.vbs <<<
'*** v2.1 *** www.dieseyer.de *******************************
'
' Datei: adminstart.vbs
' Autor: (C) 2002 by EagleSoft Ltd. / Roland Weisskopf
' Auf: www.dieseyer.de
'
' Führt Scripte und Programme unter einem anderen Useraccount aus.
' Alle notwendigen Angaben wie Benutzername und Passwort
' können über die Kommandozeile mitgegeben werden.
'
' Es können Scripte für WSCRIPT und CSCRIPT gestartet werden.
'
' Known Limits
' ============
'
' - Das Script ist für Deutsch ausgelegt. Bei anderen Sprachen muss die
' Variable strConsole entsprechend angepasst werden.
'
' - Scripte für die Konsole können nur gestartet werden, wenn das Passwort
' als Parameter mitgegeben wird.
'
' - Die Wartezeiten zum Aktivieren der Applikationsfenster kann bei
' Bedarf über die beiden Variablen intSleepShort (Wartezeit nach
' AppActivate bis zum Senden von Tastenanschlägen) und intSleepLong
' (Wartezeit nach Programmstart runas/cmd) verändert werden.
'
' - Werden Useraccount und Passwort fix einprogrammiert, muss das
' Script mit dem Encoder codiert werden.
'
'
' Starparameter (Reihenfolge spielt keine Rolle)
' =============
'
' /U Angabe des Useraccounts. Der Name muss komplett notiert werden und
' ohne Leerschlag an /U angefügt werden. Parameter ist zwingend.
' /Udomain\administrator oder /Ucomputername\administrator
'
' /S Angabe der Scripts, das gestartet werden soll. Wenn das Script im
' gleichen Verzeichnis liegt wie AdminStart.vbs, muss der Pfad zum
' Script nicht angegeben werden. Im andern Fall ist das Script mit
' der kompletten Pfadangabe zu übergeben. Parameter ist zwingend.
' /Smeinscript.vbs oder /S\\server\ablage$\meinscript.vbs
'
' Wichtig: Wenn für das Script selbst Parameter übergeben werden
' müssen, muss der ganze Schalter /S in Anführungszeichen gefasst
' werden: "/Smeinscript.vbs /parameter2 /parameter2"
'
' /P Übergibt das Passwort zum Useraccount. Ohne Angabe des Passwortes
' wird es von RunAs.Exe über die Konsole abgefragt.
'
' /C Lässt das Script mit CScript ablaufen oder startet ein Windows-
' Programm. Ohne diesen Schalter wird immer ein Script mit WScript
' gestartet.
' /C = starte Script mit CSCRIPT
' /CP = starte eine Windows-Programm. In diesem Fall muss mit /S
' der komplette Pfad angebenen werden -> /sc:\winnt\notepad.exe
'
' (C) 2002 by EagleSoft Ltd. / Roland Weisskopf
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim strInterpreter(1)
Dim strRunAsPrefix, strScript, strUser, strPass, strRunCommand
Dim objShell
Dim intLoop, intMode, intSleepShort, intSleepLong
Dim blnPass
Const cCScript = 0
Const cWScript = 1
Const cProgram = 2
Dim strConsole
'* Presets zum Anpassen
'###############################################
'# Werte User und PW nach Bedarf fix eintragen
'# und mit SCRENC dieses File codieren
'###############################################
' Useraccount: domain\account o. machine\account
strUser = ""
' Passwort
strPass = ""
'###############################################
' Pfad, Name und Parameter für das Script
strScript = ""
' Sprachenanpassung von 'ausgeführt als'
strConsole = "cmd.exe /k ( ausgeführt als "
' Wartezeit nach Fensterfokusierung
intSleepShort = 250
' Wartezeit nach Run-Command
intSleepLong = 500
' Standardmodus
intMode = cWScript
'* Presets (nicht ändern!!)
strRunAsPrefix = GetSystem32 & "\runas /user:"
strInterpreter(0) = "cmd.exe /k"
strInterpreter(1) = "wscript "
blnPass = vbFalse
Set objShell = WScript.CreateObject("WScript.Shell")
'* Command Line Parameter auswerten
if Wscript.Arguments.Count > 0 then
for intLoop = 0 to Wscript.Arguments.Count-1
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/C" then
intMode = cCScript
if right(ucase(WScript.Arguments.Item(intLoop)),1) = "P" then intMode=cProgram
end if
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/U" then
if len(WScript.Arguments.Item(intLoop))>2 then
strUser = right(WScript.Arguments.Item(intLoop),len(WScript.Arguments.Item(intLoop))-2) & " "
end if
end if
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/P" then
if len(WScript.Arguments.Item(intLoop))>2 then
strPass = right(WScript.Arguments.Item(intLoop),len(WScript.Arguments.Item(intLoop))-2)
blnPass = vbTrue
end if
end if
if left(ucase(WScript.Arguments.Item(intLoop)),2) = "/S" then
if len(WScript.Arguments.Item(intLoop))>2 then
strScript = right(WScript.Arguments.Item(intLoop),len(WScript.Arguments.Item(intLoop))-2)
Dim intPosP
intPosP=inStr(1,strScript,":\",vbTextCompare)
if intPosP=0 or intPosP>4 then
intPosP=inStr(1,strScript,"\\",vbTextCompare)
if intPosP=0 or intPosP>3 then strScript = strScriptPath & "\" & strScript
end if
end if
end if
next
end if
if strScript = "" then MissingParameter
if strUser = "" then MissingParameter
if right(strUser,1)<>" " then strUser = strUser & " "
if strPass<>"" then blnPass = vbTrue
if (intMode=cCScript) and (not blnPass) then MissingParameter
select case intmode
case cCScript
strRunCommand = strRunAsPrefix & strUser & chr(34) & strInterpreter(intMode) & chr(34)
case cWScript
strRunCommand = strRunAsPrefix & strUser & chr(34) & strInterpreter(intMode) & strScript & chr(34)
case cProgram
strRunCommand = strRunAsPrefix & strUser & chr(34) & strScript & chr(34)
end select
' MsgBox strRunCommand, , "148 :: "
objShell.Run strRunCommand
WScript.Sleep intSleepLong
if blnPass then
objShell.AppActivate GetSystem32 & "\runas.exe"
WScript.Sleep intSleepShort
' MsgBox strPass & "{enter}" & vbCRLF & intMode & vbCRLF & GetSystem32 & "\runas.exe", , "156 :: "
objShell.Sendkeys strPass & "{enter}"
select case intMode
case cCScript
WScript.Sleep intSleepLong
objShell.AppActivate strConsole & strUser & ")"
WScript.Sleep intSleepShort
objShell.Sendkeys "cscript " & chr(34) & strScript & chr(34) & "{enter}"
end select
end if
Set objShell = nothing
WScript.Quit
'********************************************************************
'* Sub MissingParameter
'* Benötigte Parameter wurden nicht übergeben
'********************************************************************
Private Sub MissingParameter
WScript.Echo "Es fehlt mindestens einer der benötigten Startparameter. Prüfe die Eingabe für /U, /P und /C."
WScript.Quit
End Sub
'********************************************************************
'* Function strScriptPath
'* Ermittle den Serverpfad des aktuellen Scripts
'********************************************************************
Private Function strScriptPath
strScriptPath = left(Wscript.ScriptFullName,len(Wscript.ScriptFullName)-len(Wscript.ScriptName)-1)
End Function
'********************************************************************
'* Function GetSystem32
'* Gibt das lokale System32-Verzeichnis zurück
'********************************************************************
Private Function GetSystem32
Dim strTemp
strTemp = strEnviron("windir")
GetSystem32 = strTemp & "\system32"
End Function
'********************************************************************
'* Function strEnviron
'* Gibt Umgebungsvariablen von Windows zurück
'********************************************************************
Private Function strEnviron(strVarName)
Dim objWindows
Set objWindows = WScript.CreateObject("WScript.Shell")
strEnviron = objWindows.ExpandEnvironmentStrings("%" + strVarName + "%")
Set objWindows = Nothing
End Function
#########################################################################
>>> aktuelledmtfdatetime.vbs <<<
'*** v9.C *** www.dieseyer.de ******************************
'
' Datei: AktuelleDMTFDateTime.vbs
' Autor: Philipp Reiser
' Autor: B.Flemming 29.07.2009
' Auf: www.dieseyer.de
'
' Wandelt die aktuelle Zeit in das DMTF DateTime Zeitformat.
' (mit Zeitverschiebung; Sommerzeit; DST)
'
'***********************************************************
Option Explicit
Dim Txt, i
' Warten, bis eine neue Sekunde beginnt
Do
WScript.Sleep 1
If InStr( Timer(), "," ) = 0 Then Exit Do
Loop
Do
Txt = Txt & AktuelleDMTFDateTime() & vbCRLF
' WScript.Sleep 1
i = i + 1 : If i > 35 Then exit Do
Loop
MsgBox Txt, , "015 :: " & WScript.ScriptName
MsgBox DMTFToDeTime( AktuelleDMTFDateTime ), , "017 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "20091112" ), , "019 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "200910021355" ), , "020 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "20090101023344" ), , "021 :: " & WScript.ScriptName
' MsgBox DMTFToDeTime( "20090729102344.000000+120" ), , "022 :: " & WScript.ScriptName
WScript.Quit
'***********************************************************
'http://msdn.microsoft.com/en-us/library/aa387237(VS.85).aspx
'
'CIM-DATETIME
'yyyymmddHHMMSS.mmmmmmsUUU
'
'The following Field Description lists the fields in the formats.
'
'yyyy Four-digit year (0000 through 9999).
' Your implementation can restrict the supported range.
' For example, an implementation can support only the years 1980 through 2099.
'
'mm Two-digit month (01 through 12).
'dd Two-digit day of the month (01 through 31).
' This value must be appropriate for the month. For example, February 31 is not valid.
' However, your implementation does not have to check for valid data.
'
'HH Two-digit hour of the day using the 24-hour clock (00 through 23).
'MM Two-digit minute in the hour (00 through 59).
'SS Two-digit number of seconds in the minute (00 through 59).
'
'mmmmmm Six-digit number of microseconds in the second (000000 through 999999).
' Your implementation does not have to support evaluation using this field.
' However, this field must always be present to preserve the fixed-length nature of the string.
'
'mmm Three-digit number of milliseconds in the minute (000 through 999).
'
's Plus sign (+) or minus sign (-) to indicate a positive or negative offset from Coordinated Universal Times (UTC).
'
'UUU Three-digit offset indicating the number of minutes that the originating time zone deviates from UTC.
' For WMI, it is encouraged, but not required, to convert times to GMT (a UTC offset of zero).
'
'
'*** v9.C *** www.dieseyer.de ******************************
Function AktuelleDMTFDateTime()
'***********************************************************
Dim DMTF, Tst
Tst = Timer
' Die (aktuell) zehntel und hundertstel Sekunden ermitteln.
' Zeit mit zwei Nachkommastellen: 14:25:36,47
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If InStr( Tst, "," ) Then
Tst = Mid( Tst, InStr( Tst, "," ) + 1 )
Else
Tst = ""
End If
If Len( Tst ) < 2 Then Tst = Tst & "0"
If Len( Tst ) < 2 Then Tst = Tst & "0"
Tst = "." & Tst
' aktuelle DMTF-Zeit (ohne Nachkommastellen)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set DMTF = CreateObject("WbemScripting.SWbemDateTime")
DMTF.SetVarDate Now(), True
' aktuelle DMTF-Zeit um Nachkommastellen erweitern
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Replace( DMTF, ".00", Tst)
Set DMTF = nothing
AktuelleDMTFDateTime = Tst
End Function ' AktuelleDMTFDateTime()
'*** v8.6 *** www.dieseyer.de ******************************
Function Zeit2DMTFDateTime( Zeit )
'***********************************************************
' http://www.dmtf.org/standards/published_documents/DSP0004V2.3_final.pdf
Dim Tst, Txt, objWMIService, colTimeZone, objTimeZone, DaylightBias
Zeit = CDate( Zeit )
Txt = Year( Zeit )
Tst = Month( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Day( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Hour( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Minute( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Tst = Second( Zeit ) : If Len ( Tst ) = 1 Then Tst = "0" & Tst
Txt = Txt & Tst
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colTimeZone = objWMIService.ExecQuery("Select * from Win32_TimeZone")
For Each objTimeZone in colTimeZone
Tst = objTimeZone.DaylightBias - objTimeZone.Bias
Next
Tst = Tst * - 1
Txt = Txt + ".000000+" & Tst : Txt = Replace( Txt, "+-", "-" )
Zeit2DMTFDateTime = Txt
End Function ' Zeit2DMTFDateTime( Zeit )
'*** v9.1 *** www.dieseyer.de ******************************
Function DMTFToDeTime( t )
'***********************************************************
' Tag Monat Jahr Stunden Minuten Sekunden
If Len( t ) = 8 Then DMTFToDeTime = Mid( t, 7, 2 ) & "." & Mid( t, 5, 2 ) & "." & Mid( t, 1, 4 ) & " 00:00"
If Len( t ) = 12 Then DMTFToDeTime = Mid( t, 7, 2 ) & "." & Mid( t, 5, 2 ) & "." & Mid( t, 1, 4 ) & " " & Mid( t, 9, 2 ) & ":" & Mid( t, 11, 2 )
If Len( t ) > 13 Then DMTFToDeTime = Mid( t, 7, 2 ) & "." & Mid( t, 5, 2 ) & "." & Mid( t, 1, 4 ) & " " & Mid( t, 9, 2 ) & ":" & Mid( t, 11, 2 ) & ":" & Mid( t, 13, 2 )
DMTFToDeTime = CDate( DMTFToDeTime )
End Function ' DMTFToDeTime( t )
#########################################################################
>>> alleprozesseundtasks.vbs <<<
'*** v9.8 *** www.dieseyer.de ******************************
'
' Datei: AlleProzesseUndTasks.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim AlleTxt, AlleArray, AlleDict
AlleTxt = AlleProzesseUndTasksText( "." )
' Ausgabe in Popup
CreateObject("WScript.Shell").PopUp "AlleProzesseUndTasksText" & vbCRLF & vbCRLF & AlleTxt, 7, "016 :: " & WScript.ScriptName
' Ausgabe in Datei; mit Datei öffnen
CreateObject("Scripting.FileSystemObject").OpenTextFile( WSCript.ScriptFullName & ".txt" , 2, true ).Write( AlleTxt )
CreateObject("WScript.Shell").Run """" & WSCript.ScriptFullName & ".txt" & """"
AlleArray = AlleProzesseUndTasksArray( "." )
WScript.Quit
'*** v9.B *** www.dieseyer.de ******************************
Function AlleProzesseUndTasksText( PC )
'***********************************************************
' WinTuC: TasksBewerten.hta UND TasksPrüfen.vbs
' Displaying the Services Running in All Processes
' http://www.microsoft.com/technet/scriptcenter/guide/sas_ser_arwi.mspx
' Außerhalb der Prozedur müssen folgende zwei Variablen definiert werden:'
' Variablen für "Function AlleProzesseUndTasksText( PC )"
' (aus ..\WinTuC_Zauberei\TasksBewerten.hta)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ReDim Preserve arrTasks( 4, 0 ) ' wird gefüllt von: Function AlleProzesseUndTasksText( PC )
' Dim dicTasks ' wird gefüllt von: Function AlleProzesseUndTasksText( PC )
' Set dicTasks = CreateObject("Scripting.Dictionary") ' enthält die Zahl, zum Zugriff auf ein arrTask() Element
' arrTasks( 0, m ) = ' "JA" Task muss laufen - sonst Fehlermeldung
' "NE" Task muss ruhen - sonst Fehlermeldung
' "NO" für nicht festgelegt - NIE Fehlermeldung
' arrTasks( 1, m ) = colProcessIDs(i) ' ist 0, wenn der Prozess NICHT läuft
' arrTasks( 2, m ) = Tst ' Tst enthält Befehlszeile des Prozess-Aufrufs;
' arrTasks( 3, m ) = objService.DisplayName
' arrTasks( 4, m ) = objService.Description
Dim Txt, Tst, i, m
Dim objIdDictionary : Set objIdDictionary = CreateObject("Scripting.Dictionary")
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service")
Dim objService
For Each objService in colServices
If objIdDictionary.Exists(objService.ProcessID) Then
Else
objIdDictionary.Add objService.ProcessID, objService.ProcessID
End If
Next
Dim colProcessIDs
colProcessIDs = objIdDictionary.Items
m = 0
For i = 0 to objIdDictionary.Count - 1
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE ProcessID = '" & colProcessIDs(i) & "'")
For Each objService in colServices
On Error Resume Next
WScript.Sleep 33 ' ! Wird nur in VBS unterstützt; nicht in HTA!
' Durch das Sleep 33 wird die CPU-Last verringert;
' die Prozedur benötigt dadurch 3x so lange.
On Error Goto 0
' \svchost.exe wird manchmal nur als \svchost ausgegeben - das wird hier korrigiert
Tst = LCase( objService.PathName )
If InStr( Tst, ".exe" ) = 0 And InStr( Tst, "\svchost" ) > 1 Then Tst = Replace( Tst, "\svchost", "\svchost.exe" ) ' : MsgBox Tst, , "0875 :: " & Titel
Txt = Txt & vbCRLF & colProcessIDs(i) & " _" & m & "_ " & Tst & ": " & objService.DisplayName & "0875 ::: " & objService.Description
If dicTasks.Exists( objService.DisplayName ) Then
' if m < 3 OR m > 95 Then MsgBox "Gibts schon: " & objService.DisplayName & " " & dicTasks.Item( objService.DisplayName ), , "0879 :: " & Titel & "'Win32_Service'"
Else
dicTasks.Add objService.DisplayName, m
ReDim Preserve arrTasks( 4, m )
arrTasks( 0, m ) = "NO"
arrTasks( 1, m ) = colProcessIDs(i) ' ist 0, wenn der Prozess NICHT läuft
arrTasks( 2, m ) = Tst ' Tst enthält Befehlszeile des Prozess-Aufrufs;
arrTasks( 3, m ) = objService.DisplayName
arrTasks( 4, m ) = objService.Description
arrTasks( 4, m ) = "ID " & colProcessIDs(i) & " (" & objService.ProcessId & "): " & objService.Description & " (Win32_Service)"
' if m < 3 OR m > 95 Then MsgBox "Neu angelegt: >" & arrTasks( 3, m ) & "<" & vbCRLF & "ist Nr. " & dicTasks.Item( arrTasks( 3, m ) ), , "0891 :: " & Titel
m = m + 1
End If
' bisher war immer: objService.Caption = objService.DisplayName
' If not objService.Caption = objService.DisplayName Then MsgBox objService.Caption & vbCRLF & objService.DisplayName, , "0896 :: " & Titel
Next
Next
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", &h10 + &h20 )
Dim objItem
For Each objItem In colItems
Tst = Trim( objItem.CommandLine )
If isNull( Tst ) Then Tst = objItem.Name ' : MsgBox "'" & Tst & "'" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0904 :: " & Titel
' MsgBox "'" & Tst & "'" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0905 :: " & Titel
' einige Prozesse werden in Win32_Process und Win32_Service aufgeführt
If objIdDictionary.Exists( objItem.ProcessID ) Then
' If objIdDictionary.Exists( objItem.ProcessID ) OR objItem.ProcessID = 0 Then
Else
' On Error Resume Next
objIdDictionary.Add objItem.ProcessID, objItem.ProcessID
If err.Number > 0 Then Tst = Tst & " .. " & objItem.ProcessID
On Error Goto 0
If dicTasks.Exists( Tst ) Then Tst = Tst & " ,, " & m
If dicTasks.Exists( Tst ) Then
MsgBox "FEHLER: Gibts schon: '" & Tst & "' - Nr.: " & dicTasks.Item( Tst ) & " (" & m & ")" & vbCRLF & "Name: >" & objItem.Name & ">" & vbCRLF & "CommandLine: >" & objItem.CommandLine & "<" & vbCRLF & "Description: >" & objItem.Description & "<" & vbCRLF & "ProcessID: >" & objItem.ProcessID & "<", , "0917 :: " & Titel
Else
' dicTasks.Add objItem.Name & " (" & objItem.ProcessId & ")", m
dicTasks.Add Trim( Tst ), m
ReDim Preserve arrTasks( 4, m )
arrTasks( 0, m ) = "NO"
arrTasks( 1, m ) = objItem.ProcessId ' ist 0, wenn der Prozess NICHT läuft
arrTasks( 2, m ) = Tst
arrTasks( 2, m ) = "" ' bei den Prozessen ist nicht der Prozessname sondern die CommandLine das entscheidende
arrTasks( 3, m ) = objItem.Name
arrTasks( 3, m ) = Tst ' bei den Prozessen ist nicht der Prozessname sondern die CommandLine das entscheidende
arrTasks( 4, m ) = objItem.Description
arrTasks( 4, m ) = "ID " & objItem.ProcessId & " (" & objItem.ParentProcessId & "): " & objItem.Description & " (Win32_Process)"
' if m < 3 OR m > 95 Then MsgBox "Neu angelegt: >" & arrTasks( 3, m ) & "<" & vbCRLF & "ist Nr. " & dicTasks.Item( arrTasks( 3, m ) ), , "0931 :: " & Titel & "'Win32_Process'"
m = m + 1
End If
End If
Next
Set colItems = nothing
Set colServices = nothing
Set objWMIService = nothing
Set objIdDictionary = nothing
On Error Resume Next ' sonst Fehler in TasksPrüfen.vbs
Txt = "0944 :: Taskliste ist erstellt. (" & Now() & ")" ' & Replace( Txt, vbCRLF, "<br>" )
window.setTimeout "InfoZeigen('" & Txt & "')" , 33
' window.setTimeout "ArrayZeigenZweiDimensionen( arrTasks )" , 333
Txt = "0949 :: Anzeige wird ""zusammen gebaut"" . . . (" & Now() & ")"
window.setTimeout "InfoZeigen('" & Txt & "')" , 66
window.setTimeout "TasksListeKonfigurationZeigen" , 99
End Function ' AlleProzesseUndTasksText( PC )
'*** v9.8 *** www.dieseyer.de ******************************
Function AlleProzesseUndTasksArray( PC )
'***********************************************************
' Displaying the Services Running in All Processes
' http://www.microsoft.com/technet/scriptcenter/guide/sas_ser_arwi.mspx
Dim Txt, Tst, i
Dim objIdDictionary : Set objIdDictionary = CreateObject("Scripting.Dictionary")
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
' Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service Where State <> 'Stopped'")
Dim colServices : Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service")
Dim objService
For Each objService in colServices
If objIdDictionary.Exists(objService.ProcessID) Then
Else
objIdDictionary.Add objService.ProcessID, objService.ProcessID
End If
Next
Dim colProcessIDs
colProcessIDs = objIdDictionary.Items
For i = 0 to objIdDictionary.Count - 1
Set colServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE ProcessID = '" & colProcessIDs(i) & "'")
For Each objService in colServices
' \svchost.exe wird manchmal nur als \svchost ausgegeben - das wird hier korrigiert
Tst = LCase( objService.PathName )
If InStr( Tst, ".exe" ) = 0 And InStr( Tst, "\svchost" ) > 1 Then Tst = Replace( Tst, "\svchost", "\svchost.exe" ) ' : MsgBox Tst, , "096 :: "
Txt = Txt & vbCRLF & colProcessIDs(i) & " _ " & Tst & ": " & objService.DisplayName & " " & objService.Description
' bisher war immer: objService.Caption = objService.DisplayName
' If not objService.Caption = objService.DisplayName Then MsgBox objService.Caption & vbCRLF & objService.DisplayName, , "101 :: "
Next
Next
AlleProzesseUndTasksArray = Txt
End Function ' AlleProzesseUndTasksArray( PC )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim i, j
Dim vntTestWert, intMitte, vntTemp
If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis
Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop
Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop
If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If
End Function ' QuickSort( vntArray, intVon, intBis )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "210 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "211 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> anmelden-an-win9x.vbs <<<
'v2.B***************************************************
' File: anmelden-an-win9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt WindowsNT-Version und Sp-Version
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHNetwork = WScript.CreateObject("WScript.Network")
Set Env = WSHShell.Environment("PROCESS")
If Env("OS") = "Windows_NT" then
MsgBox WScript.ScriptName & " läuft nur unter Win95/98/ME!"
WScript.Quit
End if
On Error Resume Next
Txt = WSHNetwork.UserName ' wenn kein Benutzer an Win9x angemeldet ist, gibt's einen Fehler
if not err.number = 0 then
WshShell.Run ("RunDLL32 Shell32,SHExitWindowsEx 0")
Else
WshShell.Run ("C:\TRIO\FLOADER.EXE /5")
End If
WScript.Quit
On Error GoTo 0
#########################################################################
>>> AnwRemoteStarten.hta <<<
</html>
<head>
<!--
'*** v9.2 *** www.dieseyer.de ****************************
'
' Datei: AnwRemoteStarten.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'*********************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
a:active { text-decoration:none; font-weight:bold; background-color:#cff; }
-->
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="Anwendungen Remote Starten"
SINGLEINSTANCE="yes"
>
<title>Anwendungen Remote Starten</title>
<style type="text/css">
body { font-size:9Pt; color:#ec0; font-weight:normal; font-family:verdana,arial,sans-serif; }
#KopfBlock { margin-top:-10px; height:87px; }
a:link { text-decoration:none; font-weight:bold; color:#ec0; }
a:visited { text-decoration:none; font-weight:bold; color:#ec0; }
a:hover { text-decoration:none; font-weight:bold; color:#226; background-color:#ec0; }
a:focus { text-decoration:none; font-weight:bold; background-color:#080; }
input { font-weight:bold; color:#226; border:4px #FFF outset; height:26px; width:95%; }
.LogStart { font-weight:normal; border:2px #FFF outset; height:1.5em; width:60px; }
.Check { font-weight:bold; margin-top:9px; border:0px #FFF outset; height:2em; width:2em; }
.PCSuche { font-weight:bold; font-size:10Pt; border:4px #FFF outset; height:26px; width:180px; }
.unsichtbar { font-weight:normal; border:0px #FFF outset; height:0px; width:0px; }
select { font-size:12pt; font-weight:normal; color:#226; border:4px #FFF outset; width:240px}
#ZeileLinks { font-family:fixedsys; margin-top:-1px; margin-left:-1px; float:left; padding:6px; width:25%; height:56px; border:1px #ec0 solid;
border-left:1px #ec0 solid; border-right:0px #ec0 solid; border-top:1px #ec0 solid; border-bottom:1px #ec0 solid; }
#ZeileRechts { margin-top:-1px; margin-left:-1px; float:left; padding:6px; width:75%; height:56px; border:1px #ec0 solid;
border-left:0px #ec0 solid; border-right:1px #ec0 solid; border-top:1px #ec0 solid; border-bottom:1px #ec0 solid; }
#Abstand { margin-left:-1px; margin-top:-1px;height:7px; border:0 px red solid; width:100%; padding:0px; font-size:0px; }
</style>
</head>
<script language="VBscript">
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const InfoJa = "-JA"
Dim LokalAnw : LokalAnw = "D:\dieseyer.neu\scr\timeset.vbs"
LokalAnw = "H:\dieseyer.neu\scr\timeset.vbs"
Dim RemotVerz : RemotVerz = "\Temp\scr\"
RemotVerz = "\Windows\Temp\"
RemotVerz = "\Temp\scr\"
Dim LokalVerz, AnwTxtLinks, AnwTxtRechts
Dim Titel : Titel = oHta.APPLICATIONNAME
Dim ErlaubteTaste
Dim AktVerz, HtaPfad, i
'' Dim BlockTxt, Kopf1Txt
Dim AnwAktive ' "JA" wenn eine Anwendung gestartet wurde, bis diese abgearbeitet ist
ReDim Preserve arrAufgAlleName( 0 ) : arrAufgAlleName( 0 ) = ""
ReDim Preserve arrAufgAlleDatei( 0 ) : arrAufgAlleDatei( 0 ) = ""
ReDim Preserve arrPCAlleNamen( 0 ) ' nur PCName
ReDim Preserve arrPCAlleDaten( 9, 0 ) ' PCName AnmeldeName AnmeldePasswort Status
' PCNameSyntaxTest "pc01"
' PCNameSyntaxTest "ap-pc"
' PCNameSyntaxTest "ds-amd"
' PCNameSyntaxTest "ds-t23"
' PCNameSyntaxTest "C010D1010055223"
' PCNameSyntaxTest "C010L00000A1EIP"
' PCNameSyntaxTest "C010L00000A07PW"
' PCNameSyntaxTest "C010L1010057445"
' PCNameSyntaxTest "M010D2500A1CUV"
' PCNameSyntaxTest "M010L25000A07PW"
' PCNameSyntaxTest "M010L2500057445"
Dim LogJa
Dim LogDatei
Dim AuswahlAlleAufg, AuswahlAllePCs, PCListeEing, PCListeType
'*********************************************************
Sub document_onKeyDown
'*********************************************************
Exit Sub
If window.event.keyCode = 13 AND ErlaubteTaste = 13 Then Call VVV()
End Sub
'*********************************************************
Function BeimLaden() ' ruft einige Routinen auf
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Dim HtaSelbst
Call HTASize
HtaSelbst = oHta.CommandLine ' der erste Parameter ist der komplette Pfad mit
' .hta-Datei, von " (Anführungszeichen) eingeschlossen
' If InStr( HtaSelbst, "~-_ENDE_-~" ) > 0 Then window.setTimeout "HtaBeenden()", 3*1000 : Exit Function
HtaSelbst = Replace( HtaSelbst, "~-_ENDE_-~", "" )
AktVerz = fso.GetParentFolderName( HtaSelbst ) ' : MsgBox "AktVerz: " & AktVerz, , "0134 :: "
AktVerz = Replace( AktVerz, """", "" ) ' : MsgBox "AktVerz: " & AktVerz, , "0135 :: "
LogDatei = AktVerz & "\" & Titel & ".log" ' : MsgBox LogDatei, , "0137 :: "
LokalVerz = fso.GetParentFolderName( LokalAnw )
AnwTxtLinks = fso.GetFileName( LokalAnw )
' Txt = Txt & "aus dem Verzeichnis " & fso.GetParentFolderName( LokalAnw )
Tst = LokalAnw
Tst = Replace( LokalAnw, fso.GetExtensionName( LokalAnw ), "log")
Txt = ""
Txt = Txt & "aus dem Verzeichnis " & fso.GetParentFolderName( LokalAnw ) & " "
Txt = Txt & "soll auf den Ziel-PCs nach <br>\\[ZielPC]\c$" & RemotVerz & " "
Txt = Txt & "kopiert und dort gestartet werden.<br>"
'' Txt = Txt & "[<a href=""" & Tst & """>" & Tst & "</a>] öffnen "
AnwTxtRechts = Txt
Call KopfAnzeigen
Call ZeilenAnzeigen
Exit Function
' MsgBox Tst, vbInformation, "0157 :: " & Titel
i = 0
i = i + 1 : window.setTimeout "PCNameAusZwischenablage()", i * 333
i = i + 1 : window.setTimeout "PCListeErmitteln()", i * 333
i = i + 1 : window.setTimeout "Block()", i * 333
If InStr( oHta.CommandLine, "~-_ENDE_-~" ) > 0 Then window.setTimeout "HtaBeenden()", 3*1000
End Function ' BeimLaden()
'*********************************************************
Sub HtaBeenden
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' MsgBox "Sub HtaBeenden", , "0176 :: " & Titel
window.setTimeout "document.all.Block.innerHTML = """"", 1*1000
window.setTimeout "document.all.Kopf1.innerHTML = """"", 2*1000
' window.setTimeout "document.all.Kopf2.innerHTML = """"", 3*1000
Dim Txt, Tst
Txt = Txt & "<span style=""font:175%"">" & Titel
Txt = Txt & "</span>"
Txt = Txt & "<span style=""font:120%; font-weight:bold; color:red; ""><br><br>''" & Titel & "'' wird beendet . . . "
Txt = Txt & "</span>"
document.all.Kopf.innerHTML = Txt
if fso.FileExists( Txt ) Then fso.DeleteFile Txt, True ' löschen der temp. VBS-Datei
' Verschieben der richtige nach temp. VBS-Datei
window.setTimeout "CreateObject(""Scripting.FileSystemObject"").MoveFile '" & Tst & "', '" & Txt & "'", 10
' Kopieren der temp. nach richtige VBS-Datei
window.setTimeout "CreateObject(""Scripting.FileSystemObject"").CopyFile '" & Txt & "', '" & Tst & "'", 1000
window.setTimeout "Self.Close()", 4 * 1000
End Sub ' HtaBeenden
'*********************************************************
Sub PCNameAusZwischenablage()
'*********************************************************
Dim Tst
' Zwischenablage für PCNameSyntaxTest vorbereiten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = document.parentwindow.clipboardData.GetData( "text" )
' MsgBox VarType( Tst ), , "0212 :: "
If VarType( Tst ) <> 8 Then Exit Sub
Tst = Replace( Tst, vbCRLF, "" )
Tst = Replace( Tst, vbLF, "" )
Tst = Replace( Tst, vbCR, "" )
Tst = Replace( Tst, " ", "" )
Tst = Replace( Tst, """", "" )
Call PCNameSyntaxTest( Tst )
End Sub ' PCNameAusZwischenablage()
'*********************************************************
Function ZeitSubtrahieren( ZeitTxt )
'*********************************************************
Dim Txt, Par1
If ZeitTxt = "" Then ZeitSubtrahieren = "" : Exit Function
If InStr( ZeitTxt, "d" ) Then Par1 = "d" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "d"
If InStr( ZeitTxt, "h" ) Then Par1 = "h" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "h"
If InStr( ZeitTxt, "m" ) Then Par1 = "m" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "n"
If InStr( ZeitTxt, "min" ) Then Par1 = "min" : Txt = Int( Replace( ZeitTxt, Par1, "" ) ) : Par1 = "n"
ZeitSubtrahieren = CDate( DateAdd( Par1, Txt * -1, now() ) )
MsgBox "ZeitTxt >" & ZeitTxt & "<" & vbCRLF & "Txt >" & Txt & "<" & vbCRLF & "ZeitSubtrahieren >" & ZeitSubtrahieren & "<" & vbCRLF & "Jetzt: " & now(), , "0240 :: "
End Function ' ZeitSubtrahieren( ZeitTxt )
'*********************************************************
Sub AufgJePCStarten
'*********************************************************
Dim Txt, i, n, m, a, p
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' Dim FileOut : Set FileOut = fso.OpenTextFile( HauptVerz & "\" & _par, 2, True ) ' 2 => neue Datei; 8 => Datei erweitern
Dim AusgewAufg : Set AusgewAufg = document.getElementsByName("AufgAuswahl")
Dim AusgewPCs : Set AusgewPCs = document.getElementsByName("PCAuswahl")
' FileOut.WriteLine AltErgbNicht & ": " & ZeitSubtrahieren( AltErgbNichtX.Value ) ' : MsgBox "AltErgbNichtX.Value: " & AltErgbNichtX.Value , , "0255 :: "
' FileOut.WriteLine AltAufgEnde & ": " & ZeitSubtrahieren( AltAufgEndeX.Value ) ' : MsgBox "AltAufgEndeX.Value: " & AltAufgEndeX.Value , , "0256 :: "
For m = 0 to PCAuswahl.length-1
If PCAuswahl( m ).checked Then
' MsgBox arrPCAlleNamen( PCAuswahl( m ).Value ), , "0260 :: "
a = 0
For n = 0 to AusgewAufg.length-1
If AusgewAufg( n ).checked Then
a = 1 : i = i + 1
' MsgBox arrAufgAlleDatei( AusgewAufg( n ).Value ) & "::::" & arrPCAlleNamen( PCAuswahl( m ).Value ), , "0265 :: "
' Txt = Txt & vbCRLF & arrAufgAlleDatei( AusgewAufg( n ).Value ) & "::::" & arrPCAlleNamen( PCAuswahl( m ).Value )
Txt = Txt & vbCRLF & vbTab & arrAufgAlleDatei( AusgewAufg( n ).Value )
FileOut.WriteLine arrPCAlleNamen( PCAuswahl( m ).Value ) & " " & arrAufgAlleDatei( AusgewAufg( n ).Value )
End If
Next
If a = 0 Then
Txt = Txt & vbCRLF & arrPCAlleNamen( PCAuswahl( m ).Value )
FileOut.WriteLine arrPCAlleNamen( PCAuswahl( m ).Value ) & " \\XXXX\\"
End If
Txt = Txt & vbCRLF
End If
Next
FileOut.Close
Set FileOut = nothing
Self.close
Exit Sub
window.setTimeout "Self.close", 2*1000
' MsgBox i & " Aufgaben wurden abgesetzt . . ." & vbCRLF & Txt , , "0286 :: "
End Sub ' AufgJePCStarten
'*********************************************************
Sub AllePCsAusw
'*********************************************************
If AuswahlAllePCs = "checked" Then
AuswahlAllePCs = ""
Else
AuswahlAllePCs = "checked"
End if
Call ZeilenAnzeigen
End Sub ' AllePCsAusw
'*********************************************************
Sub AnwendungenSuche
'*********************************************************
LokalAnw = BFFStartVerzeichnis( AktVerz ) ' Prozedur-Aufruf
Call BeimLaden
' Call ZeilenAnzeigen
End Sub ' AnwendungenSuche
'*********************************************************
Sub PCListePlusListe
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim StartVerz, ListeDatei, FileIn, Tst, i, n
StartVerz = "C:\"
StartVerz = "D:\dieseyer.neu\scr\Neuer Ordner"
ListeDatei = BFFStartVerzeichnis( StartVerz ) ' Prozedur-Aufruf
If Len( ListeDatei ) < 5 Then Exit Sub
' Einlesen der Datei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = UBound( arrPCAlleNamen )
If Len( arrPCAlleNamen( i ) ) > 10 Then i = i + 1
Set FileIn = fso.OpenTextFile( ListeDatei, 1 )
Do While Not ( FileIn.atEndOfStream )
ReDim Preserve arrPCAlleNamen( i )
Tst = FileIn.Readline
arrPCAlleNamen( i ) = Tst
Call PCAlleDatenRedim( Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = i + 1
Loop
FileIn.close
Set FileIn = nothing
Call ZeilenAnzeigen
End Sub ' PCListePlusListe
'*********************************************************
Sub PCAlleDatenRedim( Txt )
'*********************************************************
Dim SplitZeichen, arrTst, Tst, i, n
' Das Trennzeichen für Split ermitteln
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SplitZeichen = "-OK"
' Das Trennezeichen kann im Passwort vorkommen, nicht aber im
' PCNamen und nicht im AnmeldeNamen;
' Das erste Trennzeichen muss nach dem PCNamen folgen, also höchstens an 16. Stelle
' Das Passwort wird frühstens nach dem 16. Zeichen beginnen; wahrscheinlich PCName + Trennzeichen + AnmeldeName > 16
Tst = """;""" : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 19 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0355 :: "
Tst = vbTab : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 17 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0356 :: "
Tst = " " : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 17 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0357 :: "
Tst = ";" : i = InStr( Txt, Tst ) : If SplitZeichen = "-OK" AND i > 3 AND i < 17 Then SplitZeichen = Tst ' : MsgBox i & ": SplitZeichen: ]" & SplitZeichen & "[", , "0358 :: "
' Array erweitern, wenn letztes Array-Element nicht leer ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = UBound( arrPCAlleDaten, 2 ) : If not arrPCAlleDaten( 0, i ) = "" Then i = i + 1
ReDim Preserve arrPCAlleDaten( 9, i ) ' PCName AnmeldeName AnmeldePasswort Status
' Ist kein Trennzeichen für Split enthalten wird es wohl nur der PCName sein
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Txt ) < 16 AND SplitZeichen = "-OK" Then arrPCAlleDaten( 0, i ) = Txt
' Txt entspr. dem Trennzeichen für Split an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrTst = Split( Txt, SplitZeichen, -1, 1 )
For n = LBound( arrTst ) to UBound( arrTst )
Tst = arrTst( n )
If n = 0 Then arrPCAlleDaten( n, i ) = Tst
If n = 1 Then arrPCAlleDaten( n, i ) = Tst
If n = 2 Then arrPCAlleDaten( 2, i ) = Tst
If n > 2 Then arrPCAlleDaten( 2, i ) = arrPCAlleDaten( 2, i ) & SplitZeichen & Tst
' If n > 1 Then MsgBox "n: " & n & " i: " & i & vbCRLF & arrPCAlleDaten( n, i ), , "0381 :: "
Next
' Bei diesem Splitzeichen beginnt und endet Txt mit einem "
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If SplitZeichen = """;""" Then
arrPCAlleDaten( 0, i ) = Mid( arrPCAlleDaten( 0, i ), 2 )
arrPCAlleDaten( 2, i ) = Mid( arrPCAlleDaten( 2, i ), 1, Len( arrPCAlleDaten( 2, i ) ) -1 )
End If
Tst = Txt & vbCRLF & vbCRLF
Tst = Tst & "n: " & n & " i: " & i & " SplitZeichen: " & SplitZeichen & vbCRLF & vbCRLF
Tst = Tst & "PC:" & vbTab & arrPCAlleDaten( 0, i ) & vbCRLF
Tst = Tst & "Name:" & vbTab & arrPCAlleDaten( 1, i ) & vbCRLF
Tst = Tst & "Pwd:" & vbTab & arrPCAlleDaten( 2, i ) & vbCRLF
' MsgBox Tst, , "0398 :: "
End Sub ' PCAlleDatenRedim( Txt )
'*********************************************************
Sub ZeilenAnzeigen
'*********************************************************
Dim Farbe, Txt, i
Txt = Txt & "<span ID=""ZeileLinks"">"
Txt = Txt & AnwTxtLinks
Txt = Txt & "</span>"
Txt = Txt & "<span ID=""ZeileRechts"" style=""background-color:" & Farbe & """>"
Txt = Txt & AnwTxtRechts
Txt = Txt & "</span>"
Txt = Txt & "<span ID=Abstand></span>"
For i = LBound( arrPCAlleDaten, 2 ) to UBound( arrPCAlleDaten, 2 )
If Len( arrPCAlleDaten( 0, i ) ) > 3 Then
' Linker Teil der Zeile
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & "<span ID=""ZeileLinks"">"
If arrPCAlleDaten( 8, i ) = 0 Then
Txt = Txt & "<input " & AuswahlAllePCs & " class=""Check"" type=""checkbox"" name=""PCAuswahl"" value=""" & i & """> " & arrPCAlleDaten( 0, i )
Else
Txt = Txt & "<input " & " disabled class=""Check"" type=""checkbox"" name=""PCAuswahl"" value=""" & i & """> <u>" & arrPCAlleDaten( 0, i ) & "</u>"
End If
Txt = Txt & "</span>"
' Rechter Teil der Zeile
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If arrPCAlleDaten( 3, i ) = 0 Then Farbe = "#202060"
If arrPCAlleDaten( 3, i ) = 1 Then Farbe = "005" 'blau'
If arrPCAlleDaten( 3, i ) = 2 Then Farbe = "050" 'gün'
If arrPCAlleDaten( 3, i ) = 3 Then Farbe = "500" 'rot'
If arrPCAlleDaten( 3, i ) = 4 Then Farbe = "888" 'grau'
Txt = Txt & "<span ID=""ZeileRechts"" style=""background-color:" & Farbe & """>"
Txt = Txt & i & " "
' Txt = Txt & arrPCAlleDaten( 0, i ) & " "
' Txt = Txt & arrPCAlleDaten( 1, i ) & " "
' Txt = Txt & arrPCAlleDaten( 2, i ) & " "
' Txt = Txt & arrPCAlleDaten( 3, i ) & " "
Txt = Txt & arrPCAlleDaten( 4, i ) & " "
' Txt = Txt & arrPCAlleDaten( 8, i ) & " "
' Txt = Txt & arrPCAlleDaten( 9, i ) & " "
Txt = Txt & "</span>"
' Abstand zu nächsten Zeile
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Txt = Txt & "<span ID=Abstand></span>"
End If
Next
' Txt = Txt & "<br><br>" & "0453 :: " & Timer
document.all.BlockZeile.innerHTML = Txt
End Sub ' ZeilenAnzeigen
'*********************************************************
Sub AnwendungenStart
'*********************************************************
Dim i
AnwAktive = "-JA"
For i = 0 to PCAuswahl.length-1
If PCAuswahl( i ).checked Then
arrPCAlleDaten( 8, i ) = 1
arrPCAlleDaten( 3, i ) = 4 'grau'
arrPCAlleDaten( 9, i ) = "s" ' starten folgt
End If
Next
window.setTimeout "ZeilenAnzeigen", 33
window.setTimeout "RemoteAnwStarten", 333
End Sub ' AnwendungenStart
'*********************************************************
Sub RemoteAnwStarten
'*********************************************************
Dim Tst, i, m
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AusgewPCs : Set AusgewPCs = document.getElementsByName("PCAuswahl")
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0489 :: " & Timer() & " AnwAktive = " & AnwAktive
window.setTimeout "ZeilenAnzeigen", 33
If AnwAktive = "JA" Then Exit Sub
' Liste der PCs durchgehen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrPCAlleDaten, 2 ) to UBound( arrPCAlleDaten, 2 )
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0499 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
' PC soll Anwendung erhalten; durch "s"; => blau
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If arrPCAlleDaten( 9, i ) = "s" Then ' starten folgt
arrPCAlleDaten( 9, i ) = "a" ' aktiv
arrPCAlleDaten( 3, i ) = 1 'blau'
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0506 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
window.setTimeout "RemoteAnwStarten", 333
Exit For ' entspr. Exit Sub
End If
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0511 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
' PC erhält Anwendung; durch "a"; blau
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If arrPCAlleDaten( 9, i ) = "a" Then
If InfoJa = "JA" Then document.all.InfoTxt.innerHTML = "0516 :: " & i & " AnwAktive: " & AnwAktive & " - " & arrPCAlleDaten( 9, i )
AnwAktive = "JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrPCAlleDaten( 4, i ) = "0521 :: " & Timer()
' PC erreichbar?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not WMIpingOK( arrPCAlleDaten( 0, i ) ) Then
arrPCAlleDaten( 9, i ) = "e" ' ende folgt
arrPCAlleDaten( 3, i ) = 3 ' rot'
arrPCAlleDaten( 8, i ) = 0
arrPCAlleDaten( 4, i ) = "0529 :: PC ist nicht per WMI-Ping erreichbar.<br> " & Time()
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "RemoteAnwStarten", 333
Exit For ' entspr. Exit Sub
End If
arrPCAlleDaten( 4, i ) = "0537 :: Wird kopiert und gestartet: " & fso.GetFileName( LokalAnw ) & "<br>" & Time()
' Anwendung starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrPCAlleDaten( 3, i ) = 2
' AnwAktive = "-JA"
window.setTimeout "AnwendungJePCStarten '" & i & "', '" & arrPCAlleDaten( 0, i ) & "', '" & arrPCAlleDaten( 1, i ) & "', '" & arrPCAlleDaten( 2, i ) & "'", 111
window.setTimeout "RemoteAnwStarten", 333
Exit For ' entspr. Exit Sub
End If
Next
window.setTimeout "ZeilenAnzeigen", 33
End Sub ' RemoteAnwStarten
'*** v3.A*** www.dieseyer.de *******************************
Function LwFrei()
'**************************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim i
For i = 65+2 to 90
If not fso.DriveExists( Chr( i ) & ":" ) Then LwFrei = Chr( i ) & ":" : Exit Function
Next
End Function ' LwFrei()
'*********************************************************
Sub AnwendungJePCStarten( Nr, PC, User, Pwd )
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim oExec, Txt, Tst, Tyt, Ttt
Dim Lw
Lw = LwFrei
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Txt = "net use /D /Y " & Lw & ":" : Tst = ""
' Set oExec = CreateObject("WScript.Shell").Exec( Txt )
' If Not oExec.StdOut.AtEndOfStream Then
' Tst = Tst & oExec.StdOut.ReadAll
'' Tst = Tst & oExec.StdOut.ReadLine
' End If
' Set oExec = nothing
' MsgBox Tst, , "0584 :: "
' (neue) Netzverbindung herstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use " & Lw & ": \\" & PC & "\C$ " & Pwd & " " & "/User:" & PC & "\" & User : Tst = ""
Txt = "net use \\" & PC & "\IPC$ " & Pwd & " " & "/User:" & PC & "\" & User : Tst = ""
' InputBox Txt, Txt, Txt
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
Do While oExec.Status = 0
Tst = Tst & oExec.StdOut.ReadAll
Loop
' If Not oExec.StdOut.AtEndOfStream Then
' Tst = Tst & oExec.StdOut.ReadAll
' Tst = Tst & oExec.StdOut.Read(1)
' End If
Set oExec = nothing
' MsgBox Txt & vbCRLF & " => " & Tst, , "0600 :: "
' administrative Netzwerkfreigabe suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "" : i = 0
Do
i = i + 1
If not Txt = "" Then Exit Do
' If i > 4 Then MsgBox i, , "0608 :: "
If i > 4 Then Exit Do
If i = 1 Then Tst = "\\" & PC & "\c$"
If i = 2 Then Tst = "\\" & PC & "\d$"
If i = 3 Then Tst = "\\" & PC & "\e$"
If i = 4 Then Tst = "\\" & PC & "\f$"
If fso.FolderExists( Tst ) Then
Ttt = Tst & "\" & fso.GetTempName()
' MsgBox Ttt, , "0618 :: "
On Error Resume Next
err.Clear
fso.CreateFolder Ttt
On Error Goto 0
If fso.FolderExists( Ttt ) Then Txt = Tst : fso.DeleteFolder( Ttt )
Else
MsgBox "Fehlt:" & vbCRLF & vbCRLF & "]" & Tst & "[", , "0625 :: " & fso.GetTempName()
End if
Loop
If Txt = "" Then
arrPCAlleDaten( 4, Nr ) = "0630 :: Keine administrative Freigabe (C$/D$/E$/F$) auf dem PC erreichbar.<br> " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0645 :: "
Exit Sub
End If
Tyt = Split( RemotVerz, "\", -1, 1 )
For i = LBound( Tyt ) to UBound( Tyt )
Txt = Txt & "\" & Tyt( i ) & "\"
Txt = "\" & Replace( Txt, "\\", "\")
Txt = "\" & Replace( Txt, "\\", "\")
' Verzeichnis ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not fso.FolderExists( Txt ) Then
' On Error Resume Next
err.Clear
fso.CreateFolder( Txt )
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
arrPCAlleDaten( 4, Nr ) = "0665 :: Verzeichnis fehlt und kann nicht angelegt werden.<br> " & Txt & " - " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0680 :: "
Exit Sub
End If
MsgBox Txt & vbCRLF & vbCRLF & vbTab & "angelegt", , "0685 :: "
End If
Next
Tst = 0
' MsgBox LokalVerz & vbCRLF & Txt, , "0692 :: "
Tst = ShellFolderCopy( LokalVerz, Txt ) ' Prozeduraufruf
If not Tst = 0 Then
arrPCAlleDaten( 4, Nr ) = "0695 :: Fehler beim kopieren des (Ziel-) Verzeichnises; Zielverzeichnis:<br> " & Txt & " - " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0710 :: "
Exit Sub
End If
' MsgBox LokalVerz & vbcRLF & Txt & LokalAnw & vbcRLF & Tst, , "0715 :: "
LokalAnw = Txt & fso.GetFileName( LokalAnw )
Tst = "" : If fso.GetExtensionName( LokalAnw ) = "vbs" Then Tst = "wscript.exe "
MsgBox PC & vbCRLF & Tst & LokalAnw, , "0720 :: " ': Tst = 0
' Txt = "shutdown -r -f -t 10 -c """ & Titel & " - " & CreateObject("WScript.NetWork").UserName & """ -m \\" & PC
' MsgBox Txt, , "0722 :: "
' CreateObject("WScript.Shell").Run Txt, 0
Tst = 0
Tst = VbsRemoteStarten( PC, Tst & LokalAnw, Pwd, User )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not Tst = 0 Then
arrPCAlleDaten( 4, Nr ) = "0729 :: Konnte nicht gestartet werden (" & Tst & ") :<br> " & LokalAnw & " - " & Time()
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 3 'rot'
arrPCAlleDaten( 8, Nr ) = 0
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0744 :: "
Exit Sub
End If
' MsgBox Txt & LokalAnw & vbCRLF & " => " & Tst, , "0749 :: "
' MsgBox "Nr: " & Nr & vbCRLF & "PC: " & PC & vbCRLF & "User: " & User & vbCRLF & "Pwd: " & Pwd & vbCRLF & "AnwAktive: " & AnwAktive , , "0750 :: "
Tst = LokalAnw
Tst = Replace( LokalAnw, fso.GetExtensionName( LokalAnw ), "log")
Txt = ""
Txt = Txt & "0756 :: "
Txt = Txt & "Erfolgreich gestartet (und beendet?):<br> "
Txt = Txt & LokalAnw & " - " & Time() & "<br>"
Txt = Txt & "<a href=""" & Tst & """>[" & Tst & "]</a> öffnen "
' Txt = Txt & "<input class=""LogStart"" type=""checkbox"" name=""PCAuswahl"" value=""" & i & """>"
arrPCAlleDaten( 4, Nr ) = Txt
arrPCAlleDaten( 9, Nr ) = "e" ' ende
arrPCAlleDaten( 3, Nr ) = 2 'grün'
AnwAktive = "-JA"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "RemoteAnwStarten", 333
window.setTimeout "ZeilenAnzeigen", 33
' ggf. vorhandene Netzverbindung trennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "net use /D /Y " & Lw & ":" : Tst = ""
Set oExec = CreateObject("WScript.Shell").Exec( Txt )
If Not oExec.StdOut.AtEndOfStream Then
Tst = Tst & oExec.StdOut.ReadAll
End If
Set oExec = nothing
MsgBox Tst, , "0780 :: "
End Sub ' AnwendungJePCStarten( Nr, PC, User, Pwd )
'*** v9.2 *** www.dieseyer.de *******************************
Function WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'************************************************************
' Aufruf z.B.: If not WMIpingOK( ZielPC ) Then MsgBox ZielPC & " ist nicht erreichbar." : WScript.Quit
Dim Tst, objPing, objStatus
On Error Resume Next
err.Clear
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & PCName & "'")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : WMIpingOK = "Fehler: " & Tst : Exit Function
WMIpingOK = True
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
' WScript.Echo("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'************************************************************
Function ShellFolderCopy (Quelle, Ziel) ' v2.C - http://dieseyer.de
'************************************************************
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Text
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME )
Text = "\system32"
If not "Windows_NT" = CreateObject("WScript.Shell").Environment("Process")("OS") then
Text = "\system"
End If
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
Text = fso.GetFileVersion( text ) ' Versionsinfo (der Shell32.dll) holen
Text = Left ( CDbl ( text ), 3 ) ' Versionsinfo formatieren
If Text < 471 then
fso.CopyFolder Quelle, Ziel, True
Else
if not fso.FolderExists( Ziel ) then fso.CreateFolder( Ziel )
Dim ShellApp
Set ShellApp = CreateObject("Shell.Application")
Dim oZielOrdner
Set oZielOrdner = ShellApp.NameSpace( Ziel )
'Const FOF_CREATEPROGRESSDLG = &H0 ' 0
'Const FOF_MULTIDESTFILES = &H1 ' 1
'Const FOF_CONFIRMMOUSE = &H2 ' 2
'Const FOF_SILENT = &H4 ' 4
'Const FOF_RENAMEONCOLLISION = &H8 ' 8
'Const FOF_NOCONFIRMATION = &H10 ' 16
'Const FOF_WANTMAPPINGHANDLE = &H20 ' 32
'Const FOF_ALLOWUNDO = &H40 ' 64
'Const FOF_FILESONLY = &H80 ' 128
'Const FOF_SIMPLEPROGRESS = &H100 ' 256
'Const FOF_NOCONFIRMMKDIR = &H200 ' 512
On Error Resume Next
oZielOrdner.CopyHere Quelle , 1 + 16
If err.number <> 0 Then
ShellFolderCopy = err.number
Else
ShellFolderCopy = 0
End If
On Error GoTo 0
Set ShellApp = nothing ' weil es nicht mehr gebraucht wird
Set oZielOrdner = nothing
End If
Set WSHShell = nothing
Set fso = nothing
End Function ' ShellFolderCopy () ' v2.C - http://dieseyer.de
'*** v8.4 *** www.dieseyer.de *******************************
Function VbsRemoteStarten( ZielPC, Progr, Pwd, User )
'************************************************************
Dim Tx, Tst, ProcessID
' Progr = "wscript.exe " & Progr ' Ziel-Anwendung
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\" & ZielPC & "\root\cimv2")
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & ZielPC & "\root\cimv2")
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ZielPC & "\root\cimv2")
Const WbemAuthenticationLevelPktPrivacy = 6
Dim objWbemLocator : Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator")
' Dim objWMIService : Set objWMIService = objwbemLocator.ConnectServer (ZielPC, "\root\cimv2:Win32_ProcessStartup", ZielPC & "\" & User, Pwd )
Dim objWMIService : Set objWMIService = objwbemLocator.ConnectServer (ZielPC, "\root\cimv2", ZielPC & "\" & User, Pwd )
objWMIService.Security_.authenticationLevel = WbemAuthenticationLevelPktPrivacy
' Dim objWbemLocator : Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator")
' Dim objConnection : Set objConnection = objwbemLocator.ConnectServer("WebServer", "root\cimv2", "fabrikam\administrator", "password", , "kerberos:WebServer")
' objConnection.Security_.ImpersonationLevel = wbemImpersonationLevelDelegate
'
'Set objSoftware = objConnection.Get("Win32_Product")
'errReturn = objSoftware.Install("\\atl-dc-02\scripts\1561_lab.msi",,True)
'
'
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\" & ZielPC & "\root\cimv2:Win32_ProcessStartup")
Dim objStartup : Set objStartup = objWMIService.Get("Win32_ProcessStartup")
Dim objConfig : Set objConfig = objStartup.SpawnInstance_
Const SW_NORMAL = 1 : objConfig.ShowWindow = SW_NORMAL
Dim objProcess : Set objProcess = objWMIService.Get("Win32_Process")
Trace32Log "0896 :: Soll gestartet werden: """ & Progr & """ ", 1
Tst = objProcess.Create( Progr, Null, Null, ProcessID )
' Tst = objProcess.Create( Progr, Null, objConfig, ProcessID )
' Tst = objProcess.Create( Progr, CreateObject("WScript.Shell").ExpandEnvironmentStrings("%WinDir%") & "\system32", objConfig, ProcessID )
If Tst <> 0 Then
MsgBox Tst & vbCRLF & ProcessID, , "900 :: "
Trace32Log "0901 :: Konnte NICHT gestartet werden - RC " & Tst, 3
VbsRemoteStarten = Tst
Else
MsgBox Tst, , "904 :: "
Trace32Log "0904 :: Ist gestartet - Process ID: " & ProcessID, 1
VbsRemoteStarten = Tst
End If
' c:\WINDOWS\system32\rundll32.exe"
End Function ' VbsRemoteStarten( ZielPC, Progr, Pwd, User )
'*********************************************************
Sub PCListePlusPC
'*********************************************************
Dim Txt, i
Txt = UCase( PCListePlusPCX.Value )
' PCName schon in der Auswahl?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrPCAlleNamen ) to UBound( arrPCAlleNamen )
If arrPCAlleNamen( i ) = Txt Then
MsgBox "Dieser PCName ist bereits in der Liste (als Nr. " & i + 1 & ")." & vbCRLF & vbCRLF & vbTab & Txt, , "1018 :: " & Titel
Exit Sub
End If
Next
' PCName in Array übernehmen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = UBound( arrPCAlleNamen ) : If not arrPCAlleNamen( UBound( arrPCAlleNamen ) ) = "" Then i = UBound( arrPCAlleNamen ) + 1
ReDim Preserve arrPCAlleNamen( i )
arrPCAlleNamen( i ) = Txt
Call ZeilenAnzeigen
End Sub ' PCListePlusPC
'*********************************************************
Sub KopfAnzeigen
'*********************************************************
Dim Txt
Txt = ""
Txt = Txt & "<span style=""font:175%"">" & Titel & "</span>"
Txt = Txt & "<span ID=Abstand></span>"
Txt = Txt & "Einlesen der Liste der PCs und der Anwendung, die gestartet werden soll."
Txt = Txt & "<span ID=Abstand></span>"
Txt = Txt & "<input class=""PCSuche"" onClick=""AnwendungenSuche()"" accesskey=""w"" type=""submit"" value=""Anwendung wählen"" > "
Txt = Txt & "<input class=""PCSuche"" onClick=""PCListePlusListe()"" accesskey=""d"" type=""submit"" value=""PC-Liste öffnen""> "
Txt = Txt & "<input class=""PCSuche"" onClick=""AnwendungenStart()"" accesskey=""s"" type=""submit"" value=""Anwendungen starten"" >"
Txt = Txt & "<span ID=Abstand></span>"
Txt = Txt & " <input Class=""unsichtbar"" onClick=""AllePCsAusw()"" accesskey=""a"" type=""checkbox"" >"
document.all.Kopf.innerHTML = Txt
End Sub ' KopfAnzeigen
'*********************************************************
Sub AlleAufgAusw
'*********************************************************
If AuswahlAlleAufg = "checked" Then
AuswahlAlleAufg = ""
Else
AuswahlAlleAufg = "checked"
End if
Call ZeilenAnzeigen
End Sub ' AlleAufgAusw
'*********************************************************
Sub AufgAusXML( XMLDatei )
'*********************************************************
' <Aufgabe>
' <AufgName>Benutzer des PCs</AufgName>
' <AufgInfo>Ermittelt letzte Anmeldung aller Benutzer mit Profil.</AufgInfo>
' <Progr1>
' <ProgrStart>wmi-ListLogonSessionInformation.vbs %PCName%</ProgrStart>
' <ProgrText>Letzter UserLogon-Zeitpunkt</ProgrText>
' <Info></Info>
' </Progr1>
' <Progr2>
' <ProgrStart>ZeitAlleUserProfile.vbs %PCName%</ProgrStart>
' <ProgrText>Auslesen des Profildatums</ProgrText>
' <Info></Info>
' </Progr2>
' </Aufgabe>
Dim i
Dim XMLDoc : Set XMLDoc = CreateObject("Msxml2.DOMDocument")
XMLDoc.async = false
XMLDoc.load( XMLDatei )
Dim Aufgabe, Node
Dim Aufgaben : Set Aufgaben = XMLDoc.selectNodes("//Aufgabe")
For Each Aufgabe in Aufgaben
For Each Node in Aufgabe.ChildNodes
If Node.BaseName = "AufgName" Then
i = UBound( arrAufgAlleName ) : If not arrAufgAlleName( UBound( arrAufgAlleName ) ) = "" Then i = UBound( arrAufgAlleName ) + 1
ReDim Preserve arrAufgAlleName( i )
ReDim Preserve arrAufgAlleDatei( i )
arrAufgAlleName( i ) = Node.Text ' : MsgBox i & " - " & arrAufgAlleName( i ), , "1096 :: "
arrAufgAlleDatei( i ) = XMLDatei ' : MsgBox i & " - " & arrAufgAlleDatei( i ), , "1097 :: "
End If
' If Node.BaseName = "AufgInfo" Then Node.Text
Next
Next
End Sub ' AufgAusXML( XMLDatei )
'*** v9.1 *** www.dieseyer.de *******************************
Function UserTempVerz
'************************************************************
' aus 'Scriptomatic v2.0' by 'The MS Scripting Guys'
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Environment", "WQL", &h10 + &h20 )
Dim objItem
For Each objItem In colItems
If InStr( UCase( objItem.UserName ), UCase( CreateObject("WScript.Network").Username ) ) > 0 Then
If objItem.SystemVariable = vbFalse Then UserTempVerz = objItem.VariableValue
End If
Next
If InStr( UCase( UserTempVerz ), "%USERPROFILE%" ) = 1 Then
UserTempVerz = Mid( UserTempVerz, Len( "%USERPROFILE%" ) + 1 )
UserTempVerz = CreateObject("WScript.Shell").Environment("PROCESS")("USERPROFILE") & UserTempVerz
End If
' MsgBox "UserTempVerz: " & UserTempVerz, , "1125 :: " : WScript.Quit
End Function ' UserTempVerz
'*********************************************************
Sub HTASize()
'*********************************************************
Dim Tst, Txt
On Error Resume Next
window.moveto 10, 10
Tst = document.body.clientWidth
If Tst < 800 Then Tst = 800 : window.resizeto Tst + 28, document.body.clientHeight + 31
On Error Goto 0
Exit Sub
On Error Resume Next
window.resizeto Tst, Txt
' window.moveto 0, 0
' window.moveto Links, Oben
' window.innerWidth
' window.resizeto Breite, Höhe ' Größe
' window.resizeto screen.width-20, screen.height-23
On Error Goto 0
End Sub ' HTASize()
'*********************************************************
Sub SchreibeXMLDatei( DateiName)
'*********************************************************
End Sub ' SchreibeXMLDatei
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i Then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "1205 :: " & Titel
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(0)
Dim i, oFolder, oFiles, DateiX
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
i = i + 1
Next
Set oFiles = nothing
Set oFolder = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v9.2 *** www.dieseyer.de *******************************
Function BFFStartVerzeichnis( Verz )
'************************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
'Set oFolder = oFSO.GetFolder("C:\")
Dim Dialog : Set Dialog = CreateObject("UserAccounts.CommonDialog")
' Dialog.Filter = "Text Files|*.txt|All Files|*.*" ' zeigt nur *.txt
' Dialog.Filter = "Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*" ' zeigt nur *.xls
Dialog.Filter = "Alle Dateien|*.*" ' zeigt nur *.* - also ALLES
' Dialog.Filter = "Textdateien|*.txt|Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*"
Dialog.FilterIndex = 2 ' von den drei auswählbaren Filtern wird der 2. eingesetzt
Dialog.InitialDir = Verz
Dialog.ShowOpen
BFFStartVerzeichnis = Dialog.FileName
End Function ' BFFStartVerzeichnis( Verz )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
</script>
<body onLoad="BeimLaden()" bgcolor="#202060" >
<Center id="Kopf"></Center>
<span id="BlockZeile"></span>
<!--
<span id="Kopf2"></span>
<span id="Kopf1"></span>
-->
<br>
<br>
<span id=InfoTxt></span>
</body>
</html>
#########################################################################
>>> arrayanzeigen-dateiinhalt.vbs <<<
'*** v10.5 *** www.dieseyer.de *****************************
'
' Datei: arrayanzeigen-dateiinhalt.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "027 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "028 :: LogDatei: " & LogDatei
Dim arrTst, arrUnSort
Dim Tst
Tst = WScript.ScriptFullName
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrTst = DateiInhalt( Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = "037 :: UBound( arrTst ) = " & UBound( arrTst )
LogEintrag Tst
MsgBox Tst, , "039 :: "
ArrayZeigen( arrTst )
arrUnSort = arrTst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrTst, LBound( arrTst ), UBound( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = "048 :: UBound( arrTst ) = " & UBound( arrTst )
LogEintrag Tst
MsgBox Tst, , "050 :: "
ArrayZeigen( arrTst )
Tst = "054 :: UBound( arrUnSort ) = " & UBound( arrUnSort )
LogEintrag Tst
MsgBox Tst, , "056 :: "
ArrayZeigen( arrUnSort )
Tst = WScript.ScriptFullName & ".txt"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call DateiSchreiben( arrTst, Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("WScript.Shell").Run "notepad " & Tst ' geschriebene Datei anzeigen
WSHShell.Popup "= = = E N D E = = =", 2, "067 :: " & WScript.ScriptName
LogEintrag "069 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WScript.Quit
'*** v10.5 *** www.dieseyer.de *****************************
Function DateiInhalt( DateiX )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileIn : Set FileIn = fso.OpenTextFile( DateiX, 1 )
Dim Txt, Tst, i
i = 0 : ReDim Preserve Zeile(i) : Zeile(i) = ""
Do While Not ( FileIn.atEndOfStream )
' Tst = Trim( FileIn.Readline )
Tst = FileIn.Readline
' If Len( Tst ) > 2 Then
Txt = Txt & Tst & vbCRLF
ReDim Preserve Zeile(i)
Zeile(i) = Tst
i = i + 1
' End If
Loop
' MsgBox Txt, , "095 :: "
If UBound( Zeile ) < 1 AND Zeile( UBound( Zeile ) ) = "" Then Zeile( UBound( Zeile ) ) = "LEER"
FileIn.Close
Set FileIn = nothing
DateiInhalt = Zeile
End Function ' DateiInhalt( DateiX )
'*** v8.C *** www.dieseyer.de ******************************
Sub DateiSchreiben( arrDaten, ZielDatei )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut, i
Set FileOut = fso.OpenTextFile( ZielDatei, 2, True ) ' 2 => neue Datei; 8 => Datei erweitern
FileOut.WriteLine UBound( arrDaten ) & " Zeilen werden geschrieben (" & now() & ")"
For i = LBound( arrDaten ) to UBound( arrDaten )
FileOut.WriteLine arrDaten(i)
Next
FileOut.Close
Set FileOut = nothing
End Sub ' DateiSchreiben( arrDaten, ZielDatei )
'*** v8.3 *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
On Error Resume Next
Dim LogDatei ' wurde die Variable LogDatei nicht außerhalb der Prozedur definiert
On Error Goto 0
' definiert, erfolgt dies jetzt hier:
' If LogDatei = "" Then LogDatei = "c:\" & WScript.Scriptname & ".log"
If LogDatei = "" Then LogDatei = WScript.ScriptFullName & ".log"
If LogTxt = "" Then ' eine neue .LOG-Datei wird erstellt, eine vorhandene überschrieben
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
LogTxt = Replace( LogTxt, vbTab, " " )
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim i, j
Dim vntTestWert, intMitte, vntTemp
If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis
Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop
Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop
If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If
End Function ' QuickSort( vntArray, intVon, intBis )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
' LogEintrag "255 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "256 :: "
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> arrayanzeigen-dateiliste.vbs <<<
'*** v7.C *** www.dieseyer.de ******************************
'
' Datei: arrayanzeigen-dateiliste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~~~
' Const QuellVerz = "C:\dieseyer.de\scr"
Dim QuellVerz : QuellVerz = Mid( WScript.ScriptFullName, 1, InStrRev( WScript.ScriptFullName, "\" ) )
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "035 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "036 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "038 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "046 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrDateiLst, LBound( arrDateiLst ), UBound( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "054 :: " & WScript.ScriptName
LogEintrag "056 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "108 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "109 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ******************************
Function Dateilisteholen( Verz )
'***********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
' LogEintrag "127 :: Ausgeschl: " & Ausgeschl
Dim i, oFolder, oFiles, DateiX
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "136 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolder = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim i, j
Dim vntTestWert, intMitte, vntTemp
If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis
Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop
Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop
If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If
End Function ' QuickSort( vntArray, intVon, intBis )
#########################################################################
>>> arrayanzeigen-verzeichnisliste.vbs <<<
'*** v10.2 *** www.dieseyer.de *****************************
'
' Datei: arrayanzeigen-verzeichnisliste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~~~
' Const QuellVerz = "C:\dieseyer.de\scr"
Dim QuellVerz : QuellVerz = Mid( WScript.ScriptFullName, 1, InStrRev( WScript.ScriptFullName, "\" ) )
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "036 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "037 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "039 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrVerzLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrVerzLst = Verzeichnislisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "046 :: UBound( arrVerzLst ): " & UBound( arrVerzLst )
ArrayZeigen( arrVerzLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrVerzLst, LBound( arrVerzLst ), UBound( arrVerzLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrVerzLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "062 :: " & WScript.ScriptName
LogEintrag "064 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "116 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "117 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v10.2 *** www.dieseyer.de *****************************
Function Verzeichnislisteholen( Verz )
'***********************************************************
' Die Prozedur
' Verzeichnislisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Verzeichnisse zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Verzeichnisse
' in Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
Dim i, oFolders, oSubFolder, VerzX
i = 0
Set oFolders = fso.GetFolder( Verz )
Set oSubFolder = oFolders.SubFolders
For Each VerzX In oSubFolder
ReDim Preserve VerzeichnislisteholenX(i)
' ReDim Preserve Verzeichnislisteholen(i)
VerzeichnislisteholenX(i) = VerzX
i = i + 1
Next
Set oSubFolder = nothing
Set oFolders = nothing
Verzeichnislisteholen = VerzeichnislisteholenX
End Function ' Verzeichnislisteholen( Verz )
'*** v7.C *** www.dieseyer.de ******************************
Sub LogEintrag( LogTxt )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v8.3 *** www.dieseyer.de ******************************
Function QuickSort( vntArray, intVon, intBis )
'***********************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't
' QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim i, j
Dim vntTestWert, intMitte, vntTemp
If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis
Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop
Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop
If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If
End Function ' QuickSort( vntArray, intVon, intBis )
#########################################################################
>>> attributechange.vbs <<<
'*** v3.B *** www.dieseyer.de *******************************
'
' Datei: attributechange.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Setzt die Attribute aller Dateien in dem übergebenen
' Verzeichnis zurück.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim SendToLink, Text, Txt, TextX, i, lang
Dim WSHShell, fso, oArgs, ShellLink
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
SendToLink = "Attribute ändern"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
lang = 0
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
lang = lang + Len(oArgs.item(i))
if i = 0 then
Text = Left( UCase(oArgs.item(i)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
' if Text = "-S" OR Text = "-I" then SendenAnLink ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
End If
' On Error Resume Next
if fso.FileExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib.exe """ & oArgs.item(i) & """ -s -r -h "
' if fso.FolderExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib """ & oArgs.item(i) & "\*.*"" -s -r -h /s"
' if fso.FolderExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib """ & oArgs.item(i) & "\*.*"" -s -r -h /s"
if fso.FolderExists( oArgs.item(i) ) then TextX = "%comspec% /c Attrib.exe """ & oArgs.item(i) & "\*.*"" -s -r -h /s"
' WSHShell.Popup TextX, 10, WScript.ScriptName , 64
WSHShell.run TextX , 4, True
' WSHShell.run TextX , , True
' On Error GoTo 0
Text = Text & i & " " & TextX & vbCRLF
Next
'***************************************************************
' ENDE - das eigentliche Skript endet
'***************************************************************
Text = Replace(Text, "%comspec% /c", "")
Text = Replace(Text, "Attrib.exe", "attrib")
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende. (" & lang & ")" , 64
WScript.Quit
'*********************************
Sub SkriptInfo ' Sub Aufruf
'*********************************
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Entweder ein oder mehrere Dateien bzw. Verzeichnisse " & vbCRLF
Text = Text & "mit der Maus auf das Skript ziehen und fallen lassen, " & vbCRLF
Text = Text & "oder dem Skript über 'Senden an' die Dateien bzw. " & vbCRLF
Text = Text & "Verzeichnisse übergeben. " & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende." , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & SendToLink & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
#########################################################################
>>> autologonein.vbs <<<
'v2.A***************************************************
' File: AutoLogonEin.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Stellt WinNT/2k/XP auf AutoLogon
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
AutoAdminLogon ="0"
DefaultDomainName ="DS-PC"
DefaultUserName ="musik"
DefaultPassword ="musik"
Key = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
On Error Resume Next
Text = Text & "AutoAdminLogon " & vbTab & WshShell.RegRead( Key & "\AutoAdminLogon" ) & vbCRLF
Text = Text & "DefaultUserName " & vbTab & WshShell.RegRead( Key & "\DefaultUserName" ) & vbCRLF
Text = Text & "DefaultPassword " & vbTab & WshShell.RegRead( Key & "\DefaultPassword" ) & vbCRLF
Text = Text & "DefaultDomainName" & vbTab & WshShell.RegRead( Key & "\DefaultDomainName" ) & vbCRLF
On Error GoTo 0
Text = Text & vbCRLF & "Soll das automatische Login "
If WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then Text = Text & "eingeschaltet werden?"
If not WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then Text = Text & "ausgeschaltet werden?"
Antw = MsgBox (Text, 4 + 32 , WScript.ScriptName)
If Antw = vbNo Then
WshShell.Popup " . . . es bleibt alles beim Alten!" , 10, WScript.ScriptName, 64
' MsgBox " . . . es bleibt alles beim Alten!" , 64, WScript.ScriptName
WScript.Quit
End If
Text = Text & " => Ja!"
If WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then AutoAdminLogon ="1"
If not WshShell.RegRead( Key & "\AutoAdminLogon" ) = 0 Then AutoAdminLogon ="0"
' Werte schreiben
On Error Resume Next
WshShell.RegWrite Key & "\AutoAdminLogon" , AutoAdminLogon
WshShell.RegWrite Key & "\DefaultUserName" , DefaultUserName
WshShell.RegWrite Key & "\DefaultDomainName" , DefaultDomainName
' Schlüssel "\DefaultPassword" anlegen und mit Inhalt füllen; der Schlüssel fehlt manchmal
WshShell.RegWrite Key & "\DefaultPassword" , DefaultPassword , "REG_SZ"
On Error GoTo 0
Text = Text & vbCRLF & vbCRLF
On Error Resume Next
Text = Text & "AutoAdminLogon " & vbTab & WshShell.RegRead( Key & "\AutoAdminLogon" ) & vbCRLF
Text = Text & "DefaultUserName " & vbTab & WshShell.RegRead( Key & "\DefaultUserName" ) & vbCRLF
Text = Text & "DefaultPassword " & vbTab & WshShell.RegRead( Key & "\DefaultPassword" ) & vbCRLF
Text = Text & "DefaultDomainName" & vbTab & WshShell.RegRead( Key & "\DefaultDomainName" ) & vbCRLF
On Error GoTo 0
MsgBox Text
#########################################################################
>>> autologonsetzen.hta <<<
<head>
<!--
'v9.2***************************************************
' File: autologonsetzen.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'*******************************************************
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SHOWINTASKBAR="no"
-->
<title>AutoLogon einschalten</title>
<HTA:APPLICATION ID="oHTA"
SCROLL="No"
SHOWINTASKBAR="yes"
NAVIGABLE="no"
APPLICATIONNAME="AutoLogon setzen"
>
<style type="text/css">
<!--
background:#02D020;
background:#1d2160;
background:#1d2160;
-->
<!--
html, body { font-Size:12pt; color:#E0C000; font-family:Verdana; /* font-weight:bold; */
background:#601010;
}
a { font-size:100%; color:#FFFFFF; text-decoration:underline; }
a:active { color:red; }
a:link { color:#FFE000; }
a:visited { color:#E0C000; }
a:hover { color:red; }
a:active { color:#E0C000; }
input, select, textarea
{ color:#1d2160; font-weight:bold; }
-->
</style>
</head>
<script language="VBscript">
Dim WSHNet : Set WSHNet = CreateObject("WScript.Network")
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
Dim DriveList : Set DriveList = CreateObject("Scripting.FileSystemObject").Drives
Const Titel = "autologonsetzen.hta"
Dim PCxxx : PCxxx = ""
Dim TastEing
Dim Tst, AbfrageStart
'****************************************
Sub HTASize()
'****************************************
' window.moveto Links, Oben
window.moveto 30, 30 ' Position
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 640, 480
End Sub
'**************************************************************
Sub StartAnzeige()
'**************************************************************
TastEing = 13
Dim Txt
Txt = Txt & " <Span style=""font-size:14pt""> "
Txt = Txt & " <fieldset><Legend align=""Center""> Für folgenden PC wird das AutoLogon gesetzt: </legend> "
Txt = Txt & " </Span><Span style=""font-size:10pt""> "
Txt = Txt & " <br> <input Type=""text"" Name=""PCxxx"" Value=""" & PCxxx & """ > "
Txt = Txt & " <br><br> "
Txt = Txt & " Primäres DNS-Suffix des Computers: "
Txt = Txt & " <br> <input Type=""text"" Name=""DNS"" Value=""" & "mein.zuhause.de"" > "
Txt = Txt & " <br><br> "
Txt = Txt & " Anmeldename (UserID) für das Autologon: "
Txt = Txt & " <br> <input Type=""text"" Name=""User"" Value=""" & "Users\dieseyer"" > "
Txt = Txt & " <br><br> "
Txt = Txt & " Passwort für den Anmeldenamen: "
Txt = Txt & " <br> <input Type=""Password"" Name=""Pwd"" Value=""SehrGeheim"" > "
Txt = Txt & " <br><br> "
Txt = Txt & " </fieldset></Span> "
Txt = Txt & " <br><br> "
Txt = Txt & " <INPUT TYPE=""button"" accesskey=""s"" onClick=""Eintragen()"" value=""aktivieren"" > oder "
Txt = Txt & " <input TYPE=""button"" accesskey=""r"" onClick=""Entfernen()"" value=""deaktivieren""> "
Txt = Txt & " <br><br> "
document.all.AnzeigeHTA.innerHTML = Txt
End Sub ' StartAnzeige()
'**************************************************************
Sub Entfernen
'**************************************************************
DNS = Document.All.DNS.Value
PCxxx = UCase( Document.All.PCxxx.Value ) & "." & DNS
' MsgBox PCxxx & vbCRLF & User & vbCRLF & Pwd, , "115 :: " & Titel
If not WMIpingOK( PCxxx ) Then
MsgBox """" & PCxxx & """ ist nicht erreichbar", , "118 :: " & Titel
Else
Const HKEY_LOCAL_MACHINE = &H80000002
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCxxx & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "AutoAdminLogon"
strValue = 0
' MsgBox "strValue-AutoAdminLogon: " & strValue, , "127 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultPassword"
strValue = ""
' MsgBox "strValue-Pwd: " & strValue, , "133 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
Set oReg=nothing
MsgBox PCxxx & vbCRLF & vbCRLF & "ist nicht (mehr) auf AutoLogon gesetzt.", , "138 :: " & Titel
End If
End Sub ' Entfernen
'**************************************************************
Sub Eintragen
'**************************************************************
DNS = Document.All.DNS.Value
PCxxx = UCase( Document.All.PCxxx.Value ) & "." & DNS
User = UCase( Document.All.User.Value )
Pwd = Document.All.Pwd.Value
' MsgBox PCxxx & vbCRLF & User & vbCRLF & Pwd, , "152 :: " & Titel
If not WMIpingOK( PCxxx ) Then
MsgBox """" & PCxxx & """ ist nicht erreichbar", , "155 :: " & Titel
Else
Const HKEY_LOCAL_MACHINE = &H80000002
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCxxx & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "AutoAdminLogon"
strValue = 1
' MsgBox "strValue-AutoAdminLogon: " & strValue, , "165 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultUserName"
strValue = Mid( User, InStr( User, "\" ) + 1 )
' MsgBox "strValue-User: " & strValue, , "171 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultDomainName"
strValue = Left( User, InStr( User, "\" ) - 1 )
' MsgBox "strValue-DefaultDomainName: " & strValue, , "177 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strValueName = "DefaultPassword"
strValue = Pwd
' MsgBox "strValue-Pwd: " & strValue, , "183 :: " & Titel
oReg.SetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
Set oReg=nothing
MsgBox PCxxx & vbCRLF & vbCRLF & "erfolgreich auf AutoLogon gesetzt.", , "188 :: " & Titel
End If
End Sub ' Eintragen
'**************************************************************
Function WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
' Aufruf z.B.: If not WMIpingOK( ZielPC ) Then MsgBox ZielPC & " ist nicht erreichbar." : WScript.Quit
Dim objPing, objStatus
WMIpingOK = True
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & PCName & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
' WScript.Echo("machine " & machine & " is not reachable")
WMIpingOK = False
End If
Next
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
Function BeimLaden() ' ruft einige Routinen auf
'**************************************************************
call HTASize
' PCxxx = document.parentwindow.clipboardData.GetData("text")
call StartAnzeige()
End Function ' BeimLaden
'**************************************************************
Sub document_onKeyDown
'**************************************************************
If window.event.keyCode = 13 AND TastEing = 13 Then Call Eintragen()
End Sub
'----------------------------------------
</script>
<body onLoad="BeimLaden()" style="background-image:url(winpe.jpg)" >
<form >
<h2 align="center">www.dieseyer.de - autologonsetzen.hta</h2>
<table border="0" cellspacing="20px" width="0100%">
<tr >
<td align="Center" cellspacing="70%" >
<div ID=AnzeigeHTA >
</td>
</tr>
</table>
</form>
</body>
#########################################################################
>>> autostart-run.vbs <<<
'v4.4***************************************************
' File: autostart-run.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm listet die RegKeys, die Auto-Start / Auto-Run
' veranlasst
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WshShell, WSHNet, fso, ObjReg, ObjRemote, KeyX, Text, RootKey, oVal, FileOut, PC ' , FileIn ', Datei
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
If (fso.FileExists("REGOBJ.DLL")) Then ' Regobj.dll registrieren (erfordert AdminRechte)
Text = "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" ' damit läßt sich besser auf die registry zugreifen
WshShell.Run (Text),,TRUE ' muß im gleichen Verzeichnis wie das Script stehen
Set ObjReg = WScript.CreateObject("RegObj.Registry")
Else
MsgBox "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" & vbTab & " konnte nicht aufgerufen werden!", , WScript.ScriptName
WScript.Quit
End If
Text = "Von welchem Computer soll ermittelt werden, " & vbCRLF
Text = Text & "wer als letzter angemeldet war bzw. aktuell angemeldet ist?"
PC = wshnet.ComputerName
PC = "MeinPC"
PC = InputBox (Text, WScript.ScriptName, PC )
If PC = "" then PC = wshnet.ComputerName
' Set FileOut = fso.OpenTextFile( PC & ".txt" , 8, true) ' alte Datei fortsetzen
Set FileOut = fso.OpenTextFile( PC & ".txt" , 2, true) ' neue Datei
FileOut.WriteLine now() & " ===> " & PC
' Set ObjRemote = objReg.RemoteRegistry(wshnet.ComputerName) ' Objekt zeigt auf aktuellen PC (REGOBJ.DLL)
Set ObjRemote = objReg.RemoteRegistry( PC ) ' Objekt zeigt auf (Remote-) PC (REGOBJ.DLL)
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices
' HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServices
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce
' HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows
Text = "*** startet vor Kennwortabfrage - nachdem graphische Benutzeroberfläche erschienen ist "
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run"
RegKeysRead KeyX, vbCRLF & Text
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices"
RegKeysRead KeyX, ""
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services"
RegKeysRead KeyX, ""
FileOut.WriteLine
FileOut.WriteLine
Text = "*** startet nach der Kennwortabfrage / nach der Anmeldung "
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run"
RegKeysRead KeyX, vbCRLF & Text
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServices"
RegKeysRead KeyX, ""
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce"
RegKeysRead KeyX, ""
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows"
FileOut.WriteLine
FileOut.WriteLine KeyX
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
If InStr( UCase( oVal.Name ), "LOAD") Then FileOut.WriteLine ( " " & oVal.Name & vbTab & " ==> " & vbTab & oVal.Value)
' If InStr( UCase( oVal.Name ), "DEVICE") Then FileOut.WriteLine ( " " & oVal.Name & vbTab & " ==> " & vbTab & oVal.Value)
If InStr( UCase( oVal.Name ), "RUN" ) Then FileOut.WriteLine ( " " & oVal.Name & vbTab & " ==> " & vbTab & oVal.Value)
Next
Set RootKey = nothing
On Error GoTo 0
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
' c:\winnt\winstart.bat
If UCase( wshnet.ComputerName ) = UCase( PC )then
INIread "c:\winnt\win.ini"
INIread "c:\winnt\System.ini"
WinStart "c:\winnt\winstart.bat"
Else
If fso.FileExists( "\\" & PC & "\c$\winnt\win.ini" ) Then
INIread "\\" & PC & "\c$\winnt\win.ini"
INIread "\\" & PC & "\c$\winnt\System.ini"
WinStart "\\" & PC & "\c$\winnt\winstart.bat"
Else
FileOut.WriteLine
FileOut.WriteLine
FileOut.WriteLine "\\" & PC & "\c$\winnt\win.ini - nicht erreichbar"
FileOut.WriteLine "\\" & PC & "\c$\winnt\System.ini - nicht erreichbar"
FileOut.WriteLine "\\" & PC & "\c$\winnt\winstart.bat - nicht erreichbar"
End If
End If
FileOut.WriteLine
FileOut.WriteLine
FileOut.WriteLine now() & " ===> " & PC
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
WSHShell.Run ( PC & ".txt" )
WScript.Quit
'**************************************************************
Sub RegKeysRead ( KeyX, Text )
'**************************************************************
FileOut.WriteLine Text
FileOut.WriteLine KeyX
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
FileOut.WriteLine ( " ==>|" & oVal.Value & "|<==" )
Next
Set RootKey = nothing
On Error GoTo 0
End Sub ' RegKeysRead ( KeyX, Text )
'**************************************************************
'**************************************************************
Sub INIread ( Datei )
'**************************************************************
Dim i, FileIn
FileOut.WriteLine
if not fso.FileExists( Datei ) Then
FileOut.WriteLine " " & Datei & " ==> existiert nicht!!!"
Else
FileOut.WriteLine "*** " & Datei & " - Infos:"
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
If Instr( UCase( Zeile(i) ), "RUN=" ) Then FileOut.WriteLine Zeile(i)
If Instr( UCase( Zeile(i) ), "LOAD=") Then FileOut.WriteLine Zeile(i)
' If Instr( UCase( Zeile(i) ), "AIFC=") Then FileOut.WriteLine Zeile(i)
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
End If
End Sub ' INIread ( Datei )
'**************************************************************
'**************************************************************
Sub WinStart ( Datei )
'**************************************************************
Dim i, FileIn
FileOut.WriteLine
if not fso.FileExists( Datei ) Then
FileOut.WriteLine " " & Datei & " ==> existiert nicht!!!"
Else
FileOut.WriteLine "*** " & Datei & " - Infos:"
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
FileOut.WriteLine Zeile(i)
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
End If
End Sub ' WinStart ( Datei )
'**************************************************************
#########################################################################
>>> autostart-run2.vbs <<<
'v5.5***********************************************************
' File: autostart-run2.vbs
' Autor: "LICHTER"
' dieseyer.de
'
'Das folgende Programm soll
'Einträge im AutoStartVerzeichnis anzeigen
'kritische Reg-Schlüssel
' auslesen,
' speichern und
' beim nächsten Programmaufruf vergleichen und
' hinzugekommene Einträge melden.
'
' http://source-center.de/forum/showthread.php?t=9502
'***************************************************************
' Reg-Schlüssel löschen
Dim Arr(20)
DIM sch(40)
tit = "Mörfi's Reg_Viewer 0.1 für WIN2000 und höher (05/2005 BA Pankow)"
set WshShell = WScript.CreateObject("WScript.Shell")
ordner = WshShell.SpecialFolders("AllUsersStartup")
Set fso = CreateObject("Scripting.FileSystemObject")
on error resume next
Set f = fso.GetFolder(ordner)
set fc = f.Files
x ="Über den Autostartordner werden gestartet:" & vbcrlf & vbcrlf
for each item in fc
x = x & item.name & " -> " & " erstellt am: "& item.DateCreated & vbCrlf
next
ordner = WshShell.SpecialFolders("Startup")
Set f = fso.GetFolder(ordner)
set fc = f.Files
for each item in fc
x = x & item.name & " -> " & " erstellt am: "& item.DateCreated & vbCrlf
next
WshShell.PopUp x & vbcrlf & vbcrlf & "REG-Schlüssel wird gelesen. Moment bitte ....",3, tit, vbExclamation
xx = 0
Arr(1) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(2) = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(3) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnceEx\"
Arr(4) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices\"
Arr(5) = "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce\"
Arr(6) = "HKEY_USERS\S-1-5-18\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(7) = "HKEY_USERS\.DEFAULT\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(8) = "HKEY_USERS\.DEFAULT\Software\Microsoft\Windows\CurrentVersion\RunOnce\"
Arr(9) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\Run\"
Arr(10) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunOnce\"
Arr(11) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunServices\"
Arr(12) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunOnceEx\"
Arr(13) = "HKEY_USERS\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce\"
Arr(14) = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce\"
Arr(15) = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnceEx\"
dat1 = "c:\datx1.tmp "
dat = "c:\da.tmp "
dat2 = "c:\datref.tmp"
datref = ""
if fso.fileexists(dat2) then
set a = fso.opentextfile(dat2)
while not a.atendofStream
datref = datref & a.Readline
wend
a.close
end if
iText = "Über die Registry werden mindestens gestartet:" & " (15 Schlüssel wurden ausgewertet)" & vbcrlf & "***** NAME und Pfad ******" & vbcr
TextX = ""
daten1=""
z2 = 0
for g = 1 to 15
schluss = arr(g)
WshShell.Run "regedit /E " & dat1 & schluss,0,true
rs = " type " & dat1 & " > c:\da.tmp"
yyy = WshShell.Run ("cmd /C " & rs,0,true)
if not fso.FileExists(Dat) then
msgbox "Schlüssel : " & schluss & " nicht gefunden. Programm wird abgebrochen", vbExclamation, tit
wscript.quit
end if
Set FinList = FSO.OpenTextFile( trim(Dat), 1 )
TextX = FinList.Readline
extX = FinList.Readline
TextX = FinList.Readline
if textx = "["& schluss &"]" then
Do While Not (FinList.atEndOfStream)
TextX = FinList.Readline
If not Left ( TextX, 1 ) = "[" then
TextX = Replace(TextX, chr(34), "")
TextX = Replace(TextX, "\\", "\")
i1 = Instr(1, TextX,"=", 1)
if i1 > 0 then
wert = Left(TextX, i1 - 1)
daten = right(TextX, len(TextX)-i1)
else
exit do
end if
xx = xx +1
sch(xx) = schluss & wert ' für spätere Löschung
itext = itext & xx & ". ("&g&")"&vbtab & Ucase(wert) & " --> " & Lcase(daten) & vbcrlf
if fso.fileexists(dat2) then
z1 = instr(datref,daten)
if z1 = 0 then
msgbox "Achtung neuer Registry-Eintrag: " & vbcrlf & Ucase(wert) & " --> " & daten,16,tit
z2 = z2 +1
end if
end if
daten1 = daten1 & daten & vbcrlf
end if
Loop
end if
Set FinList = nothing
next
fso.DeleteFile(dat)
fso.DeleteFile(dat1)
if not fso.fileexists(dat2) then
WshShell.PopUp "Referenz-Datei " & vbcrlf & vbcrlf & Ucase(dat2) & vbcrlf & vbcrlf &"wird angelegt." & "Sollen neue Registry-Einträge legitimiert werden, dann die Referenz-Datei löschen.", 15, tit, vbExclamation
set a = fso.createtextfile(Ucase(dat2),true)
set a = fso.opentextfile(dat2,8,true)
a.write daten1
a.close
end if
itext2 =""
if z2 <> 0 then itext2 = "Alle neuen Einträge legitimieren? Wenn ja, dann Datei " & Ucase(dat2) & " löschen." & vbcrlf
itext = itext & vbcrlf & vbcrlf & itext2 & "Ein Programm davon löschen? Vorsicht geboten! Ggf. läßt sich WINDOWS nicht mehr starten"
ant = wshshell.PopUp (itext , , tit,260) ', vbExclamation
if ant = 6 then
antx = 100
do while antx > xx
antx = 100
antx = EingabeZahl("Daten-Werte-Paar löschen" & vbcrlf & "Nr. des Datensatzes eingeben:" & vbcrlf & "(0 = Abbruch)" & vbcrlf & "")*1
if antx = 0 then wscript.quit
loop
msgbox sch(antx)
antxx = sch(antx)
wshShell.RegDelete antxx
end if
Private Function EingabeZahl(Text1)
Dim ix
ix = "Zahl eingeben"
do until isnumeric(ix)
ix = Inputbox(Text1, tit ,"Zahl eingeben")
if not isnumeric(ix) then ix = "Bitte gültige Zahl eingeben"
loop
EingabeZahl = ix
End Function
#########################################################################
>>> autostart.vbs <<<
'*** v9.6 *** www.dieseyer.de ******************************
Set Fso = WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss = WScript.CreateObject ( "WScript.Shell" )
'
' Datei: autostart.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' AutoStart( PC )
' gibt ein Array zurück, in dem alle Autostarteinträge
' gelistet sind. Jedes Array-Element enthält folgende,
' durch Tabulator getrennte Informationen:
' Command Befehl, .exe
' Description Beschreibung, Name
' Location z.B. Eintrag im AutoStart-Ordner
' oder Registry-Schlüssel
' Name häufig identisch mit Description
' User z.B. 'All Users', '.DEFAULT'
' 'NT-AUTORITÄT\SYSTEM'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim ZwArray : ZwArray = AutoStart( "." )
MsgBox "Es gibt " & UBound( ZwArray ) + 1 & " Autostart-Einträge.", , "025 :: " & WScript.ScriptName
Call ArrayZeigen( ZwArray )
WScript.Quit
'*** v9.6 *** www.dieseyer.de ******************************
Function AutoStart( PC )
'***********************************************************
' Hey, Scripting Guy!
' How Can I List All the Items in the Run Key in the Registry?
' http://www.microsoft.com/technet/scriptcenter/resources/qanda/feb06/hey0220.mspx
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & PC & "\root\cimv2")
Dim colStartupCommands : Set colStartupCommands = objWMIService.ExecQuery("Select * from Win32_StartupCommand")
Dim t, i
i = 0
t = "Nr." & vbTab & ".Command" & vbTab & ".Description" & vbTab & "Location" & vbTab & ".Name" & vbTab & ".User" & vbCRLF
Dim objStartupCommand
For Each objStartupCommand in colStartupCommands
t = t & i + 1 & vbTab & objStartupCommand.Command & vbTab & objStartupCommand.Description & vbTab & objStartupCommand.Location & vbTab & objStartupCommand.Name & vbTab & objStartupCommand.User & vbCRLF
ReDim Preserve AutoStartListe(i)
AutoStartListe(i) = objStartupCommand.Command & vbTab & objStartupCommand.Description & vbTab & objStartupCommand.Location & vbTab & objStartupCommand.Name & vbTab & objStartupCommand.User
i = i + 1
' Wscript.Echo "Command: " & objStartupCommand.Command
' Wscript.Echo "Description: " & objStartupCommand.Description
' Wscript.Echo "Location: " & objStartupCommand.Location
' Wscript.Echo "Name: " & objStartupCommand.Name
' Wscript.Echo "User: " & objStartupCommand.User
Next
' ArrayZeigen( AutoStartListe )
' MsgBox t, , "060 :: " & WScript.ScriptName
' WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( WScript.ScriptFullName & ".csv", 2, true ).WriteLine ( t )
AutoStart = AutoStartListe
End Function ' AutoStart()
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
' LogEintrag "114 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "115 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> bilddatumordner.vbs <<<
' ******************************************************
' Copyright: W.Schmelz, 28.11.2006
' ******************************************************
'Datum der Bilder eines gleich zu bestimmenden Ordners suchen, Ordner
'entsprechend dem Datum schreiben mit max. 4 wählbaren Unter-Ordnern:
'Ich habe vorgeschlagen: " Original ", " Zwischen ", " Bearbeitung ".
'Ankündigung des Programmes, Unterordner und Bildordner abfragen :
Titel=" Bilder in Datums - Ordner verschieben"
X=VbCR&VbCR
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Ask=MsgBox (X&VbCR&_
" Einsortieren von Origial-Bildern in Datums-Ordner !"&X&VbCR&_
"Das Datum der Bild - Dateien eines Ordners wird gesucht,"&X&_
"Ordner werden dem Datum entsprechend angelegt, z. B.,"&X&_
""" 18.12.05 "", und in diesem Ordner z. B. die Unterordner :"&X&_
""" Original "", "" Zwischen "", "" Bearbeitung "" . Die Bild-Dateien"&X&_
"werden zum Datum in dessen 1. Unter - Ordner verschoben "&X&_
VbCR&"Diese Vorgangsweise lohnt sich nur bei sehr vielen Bildern !"&_
X&VbCR,4+64+0,Titel)
If Ask=7 then WScript.Quit ' Abbruch, wenn "Nein"("7")
Eingabe=InputBox (X&VbCR&_
"Ich schlage als Unterordner der Datums-Ordner"&X&_
"vor: ""Original"", ""Zwischen"", ""Bearbeitung"". Die"&X&_
"Bild-Dateien werden in den ersten Unter-Ordner"&X&_
"des Datums-Ordner verschoben, hier ""Original""!"&X&_
"Es sind höchstens 4 Unter-Ordner möglich und"&X&_
"diese sind mit dem Zeichen "" # "" zu trennen !"&X&VbCR&_
VbCR,Titel,"Original#Zwischen#Bearbtng")
If Eingabe="" then WScript.Quit ' Abbruch, wenn "Cancel"("")
'Eingabe überprüfen:
Fehler="0"
If Left(Eingabe,1)="#" or Right(Eingabe,1)="#" then Fehler=1
y=1 'Leerstelle vorhanden?
Do until y>Len(Eingabe)
If Mid(Eingabe,y,1)=" " then Fehler=1
y=y+1
Loop
If Fehler=1 then MsgBox X&X&_
" Die Unterordner wurden falsch eingegeben "&_
X&X,VbCritical,Titel:WScript.Quit
'Eingabe aufspalten in max. 4 Teile:
ReDim Preserve Name(4)
Name(1)="0"
Name(2)="0"
Name(3)="0"
Name(4)="0"
'Aufspaltung in Ort( )
Ort=Split(Eingabe,"#")
'Vorhandene Eingaben auswählen
ReDim Preserve Ort(4)
If not Ort(0)="" then Name(1)=Ort(0)
If not Ort(1)="" then Name(2)=Ort(1)
If not Ort(2)="" then Name(3)=Ort(2)
If not Ort(3)="" then Name(4)=Ort(3)
'Eingaben zur Sicherheit melden
Meld1=Name(1)
Meld2=Name(2)
Meld3=Name(3)
Meld4=Name(4)
If Meld2="0" then Meld2=""
If Meld3="0" then Meld3=""
If Meld4="0" then Meld4=""
MsgBox X&X&VbTab&_
"Es werden folgende Unter - Ordner angelegt : "&_
X&VbCR&VbTab&Meld1&X&VbTab&Meld2&X&VbTab&Meld3&X&VbTab&_
Meld4&X&VbCR,," Unterordner bilden !"
'Den gewünschten Bild - Ordner festlegen:
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder(0,StrPrompt,BrowseInfo,Root)
On Error Resume Next
Err.Clear
Pfad=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
'Dateien des Ordners festlegen und anschließend das Datum
'der Bild-Dateien "File" im ausgesuchten Ordner ermitteln:
Set Data=Fso.GetFolder(Pfad).Files
'Bearbeitungsschleife starten:
'Betrachtung aller Dateien des oben ausgesuchten Ordners :
For each File in Data ' < -----------
'Das Datum steht an den ersten 10 Stellen, werden 7. und 8. gestrichen,
'so wird aus " 18.12.2005 " damit " 18.12.05 "
Ordner=Left(File.DateLastModified,6)&Mid(File.DateLastModified,9,2)
Ordner=Pfad&"\"&Ordner
'Datei - Endung suchen und nur die Bilder weiter betrachten:
Ext=LCase(Right(File,3))
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
'( Endg ist "false" oder "true" )
'Nur wenn die Dateien Bilder sind, werden Ordner gemäß ihrem Datum
'angelegt, samt den gewünschten Unterordnern:
If Endg and not Fso.FolderExists(Ordner) then
Set Dat=Fso.CreateFolder(Ordner)
If not Name(1)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(1))
If not Name(2)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(2))
If not Name(3)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(3))
If not Name(4)="0" then Set Dat=Fso.CreateFolder(Ordner&"\"&Name(4))
End If
'Es werden nur Bilder in Ordner&"\"&"Original" bzw. Name(1) geschoben:
If Endg then Fso.MoveFile File,Ordner&"\"&Name(1)&"\"
Next ' < -----------
'Schluss - Meldung:
MsgBox X&X&VbTab&_
"Die Bild - Dateien des ausgesuchten Ordners wurden in "&_
X&VbTab&"die Ordner geschrieben, die dem Bild-Datum entsprechen!"&X&X,,Titel
#########################################################################
>>> bildnummeriersortier.vbs <<<
'*** v9.3 *** www.dieseyer.de *******************************
' File: BildNummerierSortier..vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Datei: "BildNummerierSortier."&"v"&"b"&""&""&""s"
'* *
'* " Ms"&"H"&"t"&"a.exe / XYZ."&"v"&"b"&""&""&"s" / V"&"b"&"Script " *
'* Solche oft skurrile Schreibweise soll den Virenscanner beruhigen ! *
'* - Hin und Her zwischen V-b-s und H-t-a beunruhigt meinen Scanner ! *
'* Bilder eines Ordners benennen und/oder nummerieren oder wahlweise *
'* Original-Bilder zweier Ordner durch Benennung nach Datum und Zeit *
'* zeitlich passend ineinander sortieren und dann durch nummerieren ! *
'* Dabei sind pro Kamera 6 Bilder pro Sekunde als möglich eingeplant! *
'* Das müsste für eine Weile auch für schnellere Kameras ausreichen ! *
'* ( Meine Canon - SLR schaffte schon manchmal 2 Bilder pro Sekunde ) *
'* Auf Wunsch kann vor die endgültigen Nrn. ein Name gesetzt werden. *
'* Die Kameranamen können angehängt werden:"08_Alp377_C" wie "Canon". *
'* Bei einer Zeitverschiebung beider Kameras, ist die Zeit eingebbar! *
'* Einfach mit diesen beiden Kameras gleichzeitig ein Bild schießen ! *
'* Die Bilder werden im ausgesuchten Ordner gespeichert. Reicht der *
'* Platz aber nicht, wird gefragt, wohin sonst diese Bilder sollen ! *
'* Gesteuert wird das durch Vorweg-Eingaben in eine H-t-a - Datei,die *
'* durch zwei Klapptafeln den Fall, einen Ordner zu behandeln von dem *
'* zweiten trennt,Bilder zweier Ordner zeitlich passend zu sortieren. *
'* Diese Original - Ordner bleiben, daher ist keine Sicherung nötig ! *
'* *
'************************************************************************
' Alle Objekte und das Andere für dieses Programm zur Verfügung stellen :
' ***********************************************************************
Set Fso=WScript.CreateObject ("Scripting.FileSystemObject")
Set Wss=WScript.CreateObject ("WScript.Shell")
Set Lwk=Fso.Drives
'Variable definieren, bei "Sub" - Programmen und "Function" sehr wichtig!
Dim Pfad1, Pfad2, Pfad3, Ziel, Name, xyz, Zahl, Zahl1, Zahl2, Bild(), Tag
Dim Sammel, Zeit(), Foto1, Monat, Jahr, Std, Min, Sek, Summe, Namen, Tag1
Dim Std1,Min1,Sek1, Foto, Anders, Foto2,Stelle, Folge, Numb, Wert1, Wert2
Titel=" Bilder benennen, nummerieren, sortieren !"
UV=VbCR&VbCR
Summe="0" 'Prüfen, wieviel Platz alle Bilder brauchen, s.u.
Datei1="C:\Temp\Vorfrage."&"h"&"t"&""&"a" 'Den Viren-Scanner beruhigen!
'*************************************************************************
'* *
If not Fso.FileExists (Datei1) then '*
'* ************************************* *
'* Nur beim allerersten Start dieses Folgende laufen lassen : *
'* Eine MsgBox zum Vorstellen aller Möglichkeiten dieses Programmes : *
'* *
'*************************************************************************
Msg=MsgBox ( UV&VbTab&"Bilder eines Ordner benennen "&_
"und / oder nummerieren !"&_
UV&VbTab&"( Dieser Ordner wird in einem Unterordner gesichert ! ) "&_
UV&VbTab&" . . . . . . oder . . . . . . "&_
UV&VbTab&"Das Programm sortiert auch originale Bilder"&_
" zweier Ordner "&UV&_
VbTab&"zeitlich passend ineinander, Datum und Zeit entsprechend!"&UV&_
VbTab&"Bei beiden Kameras sind bis zu 6 Bilder / Sek. eingeplant !"&UV&_
VbTab&"Bei einer Zeitverschiebung, ""frühere"" Kamera erst nennen !"&UV&_
VbTab&"Ggf. mit beiden Kameras eine Probeaufnahme anfertigen !"&UV&_
VbTab&"Alles wird im später ausgewählten Ordner gespeichert !"&UV&_
VbTab&"Wenn an der Stelle der Platz nicht reicht, wird informiert !"&_
UV&VbTab&"Die Original-Ordner bleiben, daher keine Sicherung nötig !"&_
UV, VbOkCancel, Titel)
If Msg="2" then WScript.Quit
End If
' **********************
'***********************************************************************
'* *
'* Folgende Datei ist hier vorweg eingearbeitet : *
'* ################################################ *
'* *
'* " Ms"&"H"&"t"&"a.exe / XYZ."&"v"&"b"&""&""&"s" / V"&"b"&"Script " *
'* Diese oft skurrile Schreibweise soll den Virenscanner beruhigen ! *
'* Hin und Her zwischen V-b-s und H-t-a beunruhigt meinen Scanner ! *
'* " H--t--a - Vorfrage . v--b--s " von W. Schmelz, 21.11.2008 *
'* Aus V--b--s - Datei eine H--t--a - Datei mit 3 Textfeldern und 2 *
'* Klick- Tasten zur Auswahl, samt Taste zum Abbrechen neu schaffen, *
'* aufrufen und die Einträge per Clipboard an V-b-s - Datei zurück ! *
'* Das geht natürlich auch in direkter Weitergabe mit den "Arg(i)" ! *
'* Hat aber auch den Nachteil, dass die Datei ein 2. Mal durchläuft! *
'* *
'***********************************************************************
Dim File, Text, Wort, Wort1, Wort2, Wort3, Kameras, Datei1
Set Fso=CreateObject ("Scripting.FileSystemObject")
Set Wss=CreateObject ("WScript.Shell")
If not Fso.FolderExists ("C:\Temp") then Fso.CreateFolder("C:\Temp")
Datei1="C:\Temp\Vorfrage."&"h"&"t"&"a"
If not Fso.FileExists (Datei1) then
' #####################################################
'
'**********************************************************************
'* *
'* Da bei Abholung der Eingaben aus Clipboard die V--b--s- Datei 2x ! *
'* durchlaufen wird, ist hier nur dieser erste Durchlauf ermöglicht ! *
'* Vor V--b--s - wird also H--t-a - Datei gesetzt, um gezielte Ein - *
'* gaben zu ermöglichen, die an die V--b--s - Datei zurück gehen !!! *
'* *
'**********************************************************************
Set File=Fso.CreateTextFile (Datei1, true)
Text=""&VbCR _
&"<Html>"&VbCR _
&"<Head>"&VbCR _
&"<Hta:Application"&VbCR _
&"Id=""Htaapp"""&VbCR _
&"Border=""5"""&VbCR _
&"Scroll=""No"""&VbCR _
&"SysMenu=""Yes"""&VbCR _
&"<Title>Vorgaben abfragen</Title>"&VbCR _
&"<Script Language=""VbScript"">"&VbCR _
&"Set Wss=CreateObject(""Wscript.Shell"")"&VbCR _
&"Set Fso=CreateObject(""Scripting.FileSystemObject"")"&VbCR _
&"Dat=""C:\Temp\Vorfrage.""&""h""&""t""&""a"" "&VbCR _
&"Dim Dat"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",""#"" "&VbCR _
&""&VbCR _
&"'************************************************************"&VbCR _
&"Sub Tafel1"&VbCR _
&"Window.ResizeTo 600,690 'Neue Breite und Höhe"&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ """&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&"" \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Green""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Bei einem Ordner bitte diese Angaben machen :"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Black""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Soll ein Name vor die nummerierten """&VbCR _
&"Txt=Txt&""Bilder gesetzt werden ?<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" bedeutet keiner ! """&VbCR _
&"Txt=Txt&""Bei """" 1 """" wird jedes """&VbCR _
&"Txt=Txt&""Bild nach dem Datum<br>"""&VbCR _
&"Txt=Txt&""benannt, um ggf. nachträglich """&VbCR _
&"Txt=Txt&""Bilder einfügen zu können ! <br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Namen"""" """&VbCR _
&"Txt=Txt&""Value=""""07_Palma"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Sollen die bisherigen Nummern erhalten bleiben - """&VbCR _
&"Txt=Txt&""oder soll<br>"""&VbCR _
&"Txt=Txt&""alles alphabetisch neu durchnummeriert """&VbCR _
&"Txt=Txt&""werden ?<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Radio"""" """&VbCR _
&"Txt=Txt&""Name=""""R2"""" ID=""""Opt1"""">"""&VbCR _
&"Txt=Txt&""Die alten Nummern sollen erhalten bleiben<br>"""&VbCR _
&"Txt=Txt&""<Input Checked Type=""""Radio"""" """&VbCR _
&"Txt=Txt&""Name=""""R2"""" ID=""""Opt2"""">"""&VbCR _
&"Txt=Txt&""Alles ist alphabetisch neu zu nummerieren<br>"""&VbCR _
&"Txt=Txt&""<br>"""&VbCR _
&"Txt=Txt&""Wenn nur ein bestimmter Teil """&VbCR _
&"Txt=Txt&""der Bilder behandelt werden<br>"""&VbCR _
&"Txt=Txt&""soll, so ist dieser zu kennzeichnen, """&VbCR _
&"Txt=Txt&""z.B. """" 533-677 """" !<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" , wenn keinerlei """&VbCR _
&"Txt=Txt&""Einschränkung sein soll !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Numb"""" """&VbCR _
&"Txt=Txt&""Value=""""0"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Input Type=""""Button"""" """&VbCR _
&"Txt=Txt&""Value=""""Mit diesen Eingaben das """&VbCR _
&"Txt=Txt&""Programm starten"""" Name=""""Information"""" """&VbCR _
&"Txt=Txt&""OnClick=Einer """&VbCR _
&"Txt=Txt&""Style=""""Background-Color:Green;Font-Size:11pt;"""&VbCR _
&"Txt=Txt&""Color:#CCCCCC;Width:270"""">"""&VbCR _
&"Txt=Txt&""</Center>"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Document.All.Info.InnerHTML=Txt"&VbCR _
&"Txt = """""&VbCR _
&"End Sub "&VbCR _
&"'***********************************"&VbCR _
&"Sub Tafel2"&VbCR _
&"Window.ResizeTo 600,690 'Neue Breite und Höhe"&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ """&VbCR _
&"Txt=Txt&""\/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&"" \/ \/ \/ \/ \/ \/ \/ \/ \/ \/ \/"""&VbCR _
&"Txt=Txt&""<br><br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Blue""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Bei zwei Ordnern bitte folgende """&VbCR _
&"Txt=Txt&""Angaben machen :<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Font Color=""""Black""""> """&VbCR _
&"Txt=Txt&""<Font Size:14pt></Font></Center>"""&VbCR _
&"Txt=Txt&""Welcher Name soll vor alle durchnummerierten<br>"""&VbCR _
&"Txt=Txt&""Bilder gesetzt werden ? """" 0 """" """&VbCR _
&"Txt=Txt&""bedeutet keiner !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Namen"""" """&VbCR _
&"Txt=Txt&""Value=""""08_Tuerk"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Sollen beide Kamera - Namen angehängt werden ?<br>"""&VbCR _
&"Txt=Txt&""Z.B. """" 08_Tuerk312_P.jpg """" """&VbCR _
&"Txt=Txt&""für """"P""""- anasonic,<br>"""&VbCR _
&"Txt=Txt&""""""C"""" für Canon. Bei """" 0 """" """&VbCR _
&"Txt=Txt&""keinen Anhang !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Kameras"""" """&VbCR _
&"Txt=Txt&""Value=""""PC"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""Läuft die zweite Kamera in der Zeit voraus ?<br>"""&VbCR _
&"Txt=Txt&""Vorsprung in """"Tag:Std:Min:Sek"""" nennen !<br>"""&VbCR _
&"Txt=Txt&"""""" 0 """" bei keinem Zeitunterschied !<br>"""&VbCR _
&"Txt=Txt&""<Input Type=""""Text"""" Name=""""Anders"""" """&VbCR _
&"Txt=Txt&""Value=""""12:01:02:15"""">"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Txt=Txt&""<Center><Input Type=""""Button"""" """&VbCR _
&"Txt=Txt&""Value=""""Mit diesen Eingaben das """&VbCR _
&"Txt=Txt&""Programm starten"""" Name=""""Information"""" """&VbCR _
&"Txt=Txt&""OnClick=Zwei """&VbCR _
&"Txt=Txt&""Style=""""Background-Color:Blue;Font-Size:11pt;"""&VbCR _
&"Txt=Txt&""Color:#CCCCCC;Width:270"""">"""&VbCR _
&"Txt=Txt&""</Center>"""&VbCR _
&"Txt=Txt&""<br><br>"""&VbCR _
&"Document.All.Info.InnerHTML=Txt"&VbCR _
&"Txt = """""&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Sub Einer"&VbCR _
&"Ask=MsgBox (VbCR&VbCR&_"&VbCR _
&"""Wurden zu dem Ordner die richtigen Angaben gemacht ?""&_"&VbCR _
&""" ""&VbCR&VbCR&_"&VbCR _
&""" Wenn sicher , dann """" ""&_"&VbCR _
&"""Ja """" anklicken !""&_"&VbCR _
&"VbCR&VbCR,VbCritical+VbYesNo, _"&VbCR _
&""" Angaben zu einem Ordner"")"&VbCR _
&"If Ask=""7"" then Exit Sub"&VbCR _
&"Wort1=Namen.Value"&VbCR _
&"If Wort1="""" then Wort1=""0"""&VbCR _
&"If Document.All.Opt1.Checked then Wort2=""1"""&VbCR _
&"If Document.All.Opt2.Checked then Wort2=""2"""&VbCR _
&"Wort3=Numb.Value"&VbCR _
&"If Wort3="""" then Wort3=""0"""&VbCR _
&"If (Left(Wort1,1)="" "" or Left(Wort2,1)="" "" or _"&VbCR _
&"Left(Wort3,1)="" "") _"&VbCR _
&" then Fso.DeleteFile Dat "&VbCR _
&"If not Fso.FileExists (Dat) then Self.Close"&VbCR _
&"Wort=""1#""&Wort1&""#""&Wort2&""#""&Wort3"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",Wort"&VbCR _
&"Self.Close"&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Sub Zwei"&VbCR _
&"Ask=MsgBox (VbCR&VbCR&_"&VbCR _
&"""Wurden zu beiden Ordnern richtige Angaben gemacht ?""&_"&VbCR _
&""" ""&VbCR&VbCR&_"&VbCR _
&""" Wenn sicher , dann """" ""&_"&VbCR _
&"""Ja """" anklicken !""&_"&VbCR _
&"VbCR&VbCR,VbCritical+VbYesNo,_"&VbCR _
&""" Angaben zu den 2 Ordnern"")"&VbCR _
&"If Ask=""7"" then Exit Sub"&VbCR _
&"Wort1=Namen.Value"&VbCR _
&"If Wort1="""" then Wort1=""0"""&VbCR _
&"Wort2=Kameras.Value"&VbCR _
&"If Wort2="""" then Wort2=""0"""&VbCR _
&"Wort3=Anders.Value"&VbCR _
&"If Wort3="""" then Wort3=""0"""&VbCR _
&"If (Left(Wort1,1)="" "" or Left(Wort2,1)="" "" _"&VbCR _
&"or Left(Wort3,1)="" "") _"&VbCR _
&" then Fso.DeleteFile Dat "&VbCR _
&"If not Fso.FileExists (Dat) then Self.Close"&VbCR _
&"Wort=""2#""&Wort1&""#""&Wort2&""#""&Wort3"&VbCR _
&"Document.ParentWindow.ClipboardData.SetData ""Text"",Wort"&VbCR _
&"Self.Close"&VbCR _
&"End Sub"&VbCR _
&"'************************************************************"&VbCR _
&"Window.ResizeTo 600,250"&VbCR _
&"Window.MoveTo 200,50"&VbCR _
&"</Script>"&VbCR _
&"</Head>"&VbCR _
&"<Body BgColor=""#d3d3d3"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:14pt;Color:Black"">"&VbCR _
&"<br><br>"&VbCR _
&"<Center>"&VbCR _
&"<Input Type=""Button"" Name=""Ende"" "&VbCR _
&"Value=""Programm abbrechen"" _"&VbCR _
&"OnClick=""Self.Close"" Style=""Font-Family: "&VbCR _
&"Arial;Font-Size:14pt;Color:Red"">"&VbCR _
&"<br><br>"&VbCR _
&"<Input Type=""Button"" Name=""Ende"" "&VbCR _
&"Value=""Bilder eines Ordners nummerieren"""&VbCR _
&" OnClick=""Tafel1"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:13pt;Color:Green;Width:270"">"&VbCR _
&" <Input Type=""Button"" Name=""Start"" """""&VbCR _
&"Value=""Bilder zweier Ordner einsortieren"""&VbCR _
&" OnClick=""Tafel2"" Style=""Font-Family:Arial; "&VbCR _
&"Font-Size:13pt;Color:Blue;Width:270"">"&VbCR _
&"<br><br>"&VbCR _
&"</Center>"&VbCR _
&"<Center><div Id=Einblenden></Center>"&VbCR _
&"<Center><div Id=Info></Center>"&VbCR _
&"</Body>"&VbCR _
&"</Html>"&VbCR _
&""&VbCR _
File.WriteLine(Text)
File.Close
' Die hier geschriebene H--t--a - Datei wird vornweg ans Laufen gebracht :
' *************************************************************************
Wss.Run Datei1, , true '"true" heißt: erst weiter, wenn beendet
End If
' ############################
' Bei Abbruch in Datei 1 ist an dieser Stelle abzubrechen :
' *********************************************************
If not Fso.FileExists (Datei1) then WScript.Quit
' " Wort ", d.h. die Ergebnisse der Voranfage, aus dem Clipboard abholen :
' ************************************************************************
Set Arg=WScript.Arguments
If Arg.Count=0 then
Board 'Subprogramm zur Abfrage des Zwischenspeichers
WScript.Quit
End If
Wort=Arg(0)
' *********************************************************************
Sub Board
Wss.Run "Ms"&"H"&"t"&"a.exe V"&"b"&"Script:"&_
"(CreateObject(""WScript.Shell"")."&_
"Run("""""""& WScript.ScriptFullName&""""" """""""&Chr(38)&_
"Document.ParentWindow.ClipboardData."&_
"GetData(""Text"")"&Chr(38)&"""""""""))(Window.Close)"
End Sub
' *********************************************************************
WScript.Sleep 500
If Fso.FileExists (Datei1) then Fso.DeleteFile Datei1
' Den Speicher zur Sicherheit gezielt mit neutralem Text überschreiben!
' *********************************************************************
Wss.Run "Ms"&"H"&"t"&"a.exe V"&"b"&"Script:"&_
"(Document.ParentWindow.ClipboardData."&_
"SetData(""Text"","""&" Ätsch ! ?"&"""))(Window.Close)"
If Wort="#" then WScript.Quit 'Wenn Fenster mit "X" geschlossen!
'Die Voreintragungen, das Wort1 bzw. Wort2 festlegen :
'*****************************************************
Wort1=""
Wort2=""
If Left(Wort,1)="1" then Wort1=Right(Wort,Len(Wort)-2)
If Left(Wort,1)="2" then Wort2=Right(Wort,Len(Wort)-2)
If Wort1<>"" then 'Ende s. Dateimitte
' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§
'Folgende ältere Datei ist in diesem Programm eingearbeitet :
' ***********************************************************
' * *
' * Dateiname : " BildName.v-b-s " *
' * *
' * Bildnamen im Ordner ändern, alte Nr. bleibt erhalten, *
' * - ggf. nur einen ausgewählten Bereich neu benennen! *
' * Oder alles (!) wird neu sortiert mit laufender Nr. ! *
' * Oder Originale werden nach Entstehungsdatum benannt- *
' * es sind bis zu 6 Bilder mit gleichem Datum möglich -, *
' * um sie in andere Gruppen zeitlich passend einzufügen! *
' * *
' * CopyRight: W. Schmelz 27.10.2008 *
' * *
' ***********************************************************
Set Fso = CreateObject ("Scripting.FileSystemObject")
'Dim UV, UVW, XX, NN, Pfad, Fso, Ttl, Zahl, Bild(), Weg
'Dim Zone, Anfg, Ende, Nrn()
' Neu bstimmen, damit keine Doppelfestlegungen :
' **********************************************
Dim UVW, XX, NN, Pfad, Titel, Weg, Zone, Anfg, Ende, Nrn()
' Ebenso sind viele Bezeichnungen dieser alten Datei zu ändern !
'***************************************************************
'Abkürzungen für die MsgBox
UV=VbCR&VbCR
UVW=UV&VbCR
XX=VbTab
Titel=" Bilddateien eines Ordners umbenennen !"
' Neu in dieser eingearbeiteten Datei sind :
'*******************************************
' Die Anfangs - Eingaben in alle deren Bestandteile unterteilen :
' ****************************************************************
Zahl=Split(Wort1,"#")
' Die Anfangs - Eingaben definieren u. genauestens kontrollieren :
' ****************************************************************
Namen=Zahl(0)
Folge=Zahl(1)
Numb=Zahl(2)
' Eine Kontrollmeldung aller der vorhin getätigten Vor-Auswahlen :
' ****************************************************************
Satz=Satz&UV&VbCR&"Folgende Angaben wurden bisher eingetragen"
Satz=Satz&VbCR&"*************************************"
If Namen="0" then _
Satz=Satz&UV&"Es wird kein Name vor diese Bilder gesetzt !"
If Namen="1" then _
Satz=Satz&UV&"Die Bilder werden nach dem Datum benannt !"&UV&VbCR
If Len(Namen)>=2 then
Satz=Satz&UV&"Vor alle Bilder kommt der gemeinsame Name :"
Satz=Satz&VbCR&Namen
End If
If Namen<>"1" then
Satz=Satz&UV&"Bei der Nummerierung der Bilder des Ordners"&VbCR
If Folge="1" then
Satz=Satz&"soll die bisherige Nummer des Bildes bleiben !"
else
Satz=Satz&"werden die Bilder alphabetisch nummeriert !"
End If
If Numb="0" then
Satz=Satz&UV&"Es werden alle Bilder des Ordners behandelt !"
Satz=Satz&UV&UV
else
Satz=Satz&UV&"Nur die Bilder "&Numb&" werden behandelt !"
Satz=Satz&UV&UV
End If
End If
Test=MsgBox ( Satz, VbInformation + VbOkCancel, Titel )
If Test="2" then WScript.Quit
' Den Bild - Ordner in einem Browser auswählen :
' **********************************************
Set Shl=CreateObject ( "Shell.Application" )
Set ObF=Shl.BrowseForFolder ( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad=ObF.Self.Path
If Err.Number>0 then WScript.Quit
Set All=Nothing
On Error GoTo 0 'Ignorieren der Fehler wieder aufheben !
Msg=MsgBox ( UV&VbCR&"Zur Behandlung wurde ausgewählt : "&Pfad&_
UV&VbCR, VbInformation + VbOkCancel, Titel )
If Msg="2" then WScript.Quit
' Jetzt folgt die Kette der benötigten Sub - Programm - Aufrufe :
' ***************************************************************
Wahlen
If Weg<>"1" then Sicher 'Alle Bilder sichern!
Sammeln 'Ist noch unsortiert!
If not Zone="" then Bereich
If Weg=1 then Pruef1 'Sichern erst danach !
Sortieren 'Die Bilder sortieren!
If Weg=2 then Pruef2
NeuName
' ************************************************************
' Es folgen jetzt alle die oben aufgerufenen Sub - Programme :
' ************************************************************
Sub Wahlen
' Der nun folgende Abschnitt wurde weitgehend umgearbeitet !
' **********************************************************
' Die Zahl der Bilder im Ordner prüfen :
' **************************************
Set FsF=Fso.GetFolder(Pfad)
Set FsFf=FsF.Files
Zahl="0"
For each File in FsFf
Zahl=1+Zahl
Next
If Zahl="0" then MsgBox UVW&_
" Dies Verzeichnis enthält keine Dateien !"&_
UVW, VbCritical, Titel : WScript.Quit
' Die Eingaben vom Anfang in dieses bestehende Programm einarbeiten :
' *******************************************************************
NN=Namen
If NN="" then WScript.Quit
If NN="0" then NN=""
If NN="1" then
Sicher 'Die Bilder sichern
Datum 'Umbenennung gemäß Datum durchführen!
End If
Weg=Folge 'Bezeichnungen umarbeiten !
If Weg="" then WScript.Quit
If NN="" then
If Weg="2" then Frg2=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
"Die Bilder werden nicht benannt, aber alphabet. nummeriert ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg2="7" then WScript.Quit
End If
If NN<>"" then
If Weg="2" then Frg2=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
"Bilder werden """&NN&""" genannt, alphabet. nummeriert ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg2="7" then WScript.Quit
End If
If Numb="0" then Numb=""
If Weg="1" then Zone=Numb
If Weg="1" and Zone<>"" then Teil="Einzelne "
If NN="" then
If Weg="1" then Frg4=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
Teil&"Die Bilder werden nicht benannt, aber die Nr. bleibt ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg4="7" then WScript.Quit
End If
If NN<>"" then
If Weg="1" then Frg4=MsgBox (UVW&XX&XX&" W A R N U N G !"&UVW&XX&_
Teil&"Bilder werden """&NN&""" genannt, die Nr. bleibt ! "&_
UV&XX&"Wenn nicht gewünscht "" Nein "" tippen !"&UVW, 4, Titel)
If Frg4="7" then WScript.Quit
End If
If Weg="1" then 'Falls alte Nrn. bleiben sollen:
' Sind die vorhandenen Nummern mindestens 3 - stellig ?
' Gibt es Probleme in der Bezeichnung (08_0030_C.jpg) ?
' *****************************************************
Set Ort=Fso.GetFolder(Pfad).Files
For each File in Ort
Nr=Left(Right(File,7),3)
Z1=Left(Nr,1)
Z2=Mid(Nr,2,1)
Z3=Right(Nr,1)
If not (Asc(Z1)>47 and Asc(Z1)<58 and Asc(Z2)>47 and _
Asc(Z2)<58 and Asc(Z3)>47 and Asc(Z3)<58) then _
MsgBox UVW&" Fehler in der alten Nummerierung !"&_
UV&" Die Nr. sind nicht mind. 3 - stellig !"&_
UVW, VbCritical, Titel : WScript.Quit
Next
End If
End Sub
' ******************************************************************
Sub Sicher
' Alle Dateien im Ordner "Pfad" zählen, ihre Gesamtgröße ermitteln :
' ******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
Zahl="0"
For each i in Data
Zahl=1+Zahl
Summe=Summe+i.Size 'Summierung der Dateigrößen
Next
' Festplatte "X:\" analysieren, ob noch genug Platz, sonst Abbruch :
' ******************************************************************
Ziel=Left(Pfad,2) 'Die Ziel-Festplatte ermitteln
Set Lwrk=Fso.GetDrive(Ziel)
If Lwrk.FreeSpace<Summe+300000000 then '300 MB Rest lassen!
MsgBox UV&UV&"Das Speichermedium "&Ziel&"\ hat nicht genug"&_
UV&"Restanteil an Platz ! ! !"&UV&UV,VbCritical,Titel:WScript.Quit
End If
' Wenn dieser noch nicht vorhanden, einen Sicherungsordner anlegen :
' ******************************************************************
If not Fso.FolderExists (Pfad&"\Sicherng") then
Fso.CreateFolder(Pfad&"\Sicherng")
else
MsgBox UV&UV&" Es existiert bereits ein Sicherungsordner !?"&_
UV&UV, VbCritical, Titel : WScript.Quit
End If
' Alle Bilder des ausgesuchten Ordners werden jetzt gesichert :
' *************************************************************
Set Sich=Fso.GetFolder(Pfad)
Set Sichg=Sich.Files
For each File in Sichg
Fso.CopyFile File,Pfad&"\Sicherng\"
Next
' ********************************************************
' Die Kontrolle, ob die Sicherung korrekt angelegt wurde !
' Sonst der Abbruch, wenn die Ordner-Größen ungleich sind!
' ********************************************************
Set Folder1 = Fso. GetFolder ( Pfad ) 'Gesamtordner!
Set Folder2 = Fso. GetFolder ( Pfad & "\Sicherng\" )
Wert1 = Folder1.Size/2 ' " /2 " : Die Sicherung ist dabei!
Wert2 = Folder2.Size
If Wert1 <> Wert2 then
MsgBox UV & UV & _
"Die Sicherung ist nicht gelungen !" & UV & _
"So muss halt abgebrochen werden !" & UV & _
"Ggf. alles noch einmal versuchen !" & UV & _
UV, VbInformation, Titel
Fso.DeleteFolder ( Pfad & "\Sicherng" )
WScript.Quit
End If
End Sub
' ******************************************************************
Sub Datum
' Prüfen, ob nur Bild - Dateien enthalten, sonst kommt der Abbruch :
' ******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
For each i in Data
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung von i
If not (Endg="jpg" or Endg="tif" or Endg="raw") then
MsgBox UV&i&" ist keine Bild-Datei !!!"&UV, , Titel
WScript.Quit
End If
Next
' Auf die Sek. exaktes Datum der Original - Dateien "i" des Ordners :
' *******************************************************************
Set Data=Fso.GetFolder(Pfad).Files
For each i in Data
Name=Left(i.DateLastModified,19) 'Datum der originalen Bilder i
'In "Name" Tag, Monat, Jahr, Std, Min, Sek finden:
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
'*****************************************************************
'* *
'* Bilder des Ordners benennen mit dem Namen gemäß der Zeit: *
'* Falls gleicher Zeit- Name schon da, an den neuen gleichen *
'* Namen "1" bis "5" anhängen, wird dann dahinter sortiert ! *
'* Es sind also 6 Bilder pro Sekunde dabei hier eingeplant ! *
'* *
'*****************************************************************
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung von i
Name=Pfad&"\"&Jahr&Monat&Tag&Std&Min&Sek 'ohne Datei- Endung
If not Fso.FileExists(Name&"."&Endg) then
Fso.MoveFile i,Name&"."&Endg
ElseIf (Fso.FileExists(Name&"."&Endg) and not _
Fso.FileExists(Name&"_1."&Endg)) then
Name=Name&"_1."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and not _
Fso.FileExists(Name&"_2."&Endg)) then
Name=Name&"_2."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and not _
Fso.FileExists(Name&"_3."&Endg)) then
Name=Name&"_3."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and _
Fso.FileExists(Name&"_3."&Endg) and not _
Fso.FileExists(Name&"_4."&Endg)) then
Name=Name&"_4."&Endg
Fso.MoveFile i,Name
ElseIf (Fso.FileExists(Name&"."&Endg) and _
Fso.FileExists(Name&"_1."&Endg) and _
Fso.FileExists(Name&"_2."&Endg) and _
Fso.FileExists(Name&"_3."&Endg) and _
Fso.FileExists(Name&"_4."&Endg) and not _
Fso.FileExists(Name&"_5."&Endg)) then
Name=Name&"_5."&Endg
Fso.MoveFile i,Name
End If
Next
' Eine Schlussmeldung wird jetzt ausgegeben :
' *******************************************
MsgBox UV&XX&"Die Bilder sind nach dem Datum benannt !"&_
" "&UV, , Titel
WScript.Quit
End Sub
' *************************************************************
Sub Sammeln
' Die Bilder sammeln, nummeriert nach derem Eingang !
' ***************************************************
Set Ort=Fso.GetFolder(Pfad).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Ext=LCase(Right(File,3))
If Weg=1 then
Nr=Left(Right(File,8),4)
Z1=Left(Nr,1)
Z2=Mid(Nr,2,1)
Z3=Mid(Nr,3,1)
Z4=Right(Nr,1)
' Prüfen, ob mindestens vierstellige Nr. da sind :
' ************************************************
If not (Asc(Z1)>47 and Asc(Z1)<58 and Asc(Z2)>47 and _
Asc(Z2)<58 and Asc(Z3)>47 and Asc(Z3)<58 and Asc(Z4)>47 _
and Asc(Z4)<58) then Drei
'(Sub-Programm, das prüft, ob wenigstens dreistellige Nr.,
' und evtl. eine "0" ergänzt !)
End If
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
If Endg then Bild(i)=File
If not Endg then i=i-1
i=i+1
Next
Zahl=i-1
' Sind keine Bilder vorhanden ? !
' *******************************
If Zahl="0" then
MsgBox UV&UV&XX&_
"**********************************"&UV&_
XX&"Es ist kein Bild vorhanden !!! "&_
" "&UV&_
XX&"**********************************"&_
UVW, VbCritical, Titel : WScript.Quit
End If
If Zone="" then
Anfg="1"
Ende=Zahl
End If
End Sub
' *************************************************************
Sub Bereich
Lang=Len(Zone)
If Mid(Zone,2,1)="-" then
Anfg=Left(Zone,1)
Ende=Mid(Zone,3,Lang-2)
End If
If Mid(Zone,3,1)="-" then
Anfg=Left(Zone,2)
Ende=Mid(Zone,4,Lang-3)
End If
If Mid(Zone,4,1)="-" then
Anfg=Left(Zone,3)
Ende=Mid(Zone,5,Lang-4)
End If
End Sub
' *************************************************************
Sub Pruef1
' Ist eine Nr. etwa doppelt vorhanden ?
' *************************************
x=1
Do until x>Zahl
y=1
Do until y>Zahl
If Mid(Bild(y),Len(Bild(y))-7,4)=Mid(Bild(x),Len(Bild(x))-7,4) _
and x<>y then MsgBox UVW&_
" In Nummerierung war Nr. doppelt !"&_
UVW, VbCritical, Titel : WScript.Quit
y=y+1
Loop
x=x+1
Loop
Sicher
End Sub
' *************************************************************
Sub Sortieren
' Diese Bilder alphabetisch sortieren :
' *************************************
For i=1 to Zahl
For k=i+1 to Zahl
If Bild(i)>Bild(k) then
Y=Bild(i)
Bild(i)=Bild(k)
Bild(k)=Y
End if
Next
Next
End Sub
' *************************************************************
Sub Pruef2
' Ist der Name schon vorhanden ?
' ******************************
Lang=Len(NN)
Da="0"
x=1
Do until x>Zahl
If Left(Fso.GetFileName(Bild(x)),Lang)=NN then Da=1
x=x+1
Loop
If Da=0 then Exit Sub
' Sonst einen Hilfsnamen festlegen :
' **********************************
x=1
Do until x>Zahl
Ext=Lcase(Right(Bild(x),3))
Fso.MoveFile Bild(x),Pfad&"\"&"abc"&x&"."&Ext
Bild(x)=Pfad&"\"&"abc"&x&"."&Ext
x=x+1
Loop
End Sub
' *************************************************************
Sub Drei
' Die Bilder sammeln, nummeriert nach ihrem Eingang, und prüfen :
' ***************************************************************
Set Ort=Fso.GetFolder(Pfad).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Ext=LCase(Right(File,3))
' Den Ordnerinhalt auf Bilder prüfen :
' ************************************
Endg= Ext="jpg" or Ext="bmp" or Ext="gif" or Ext="tif" or Ext="raw"
If Endg then Bild(i)=File
If not Endg then i=i-1
i=i+1
Next
Zahl=i-1
' Sind keine Bilder vorhanden ? !
' *******************************
If Zahl="0" then
MsgBox UV&UV&XX&_
"**********************************"&UV&_
XX&"Es ist kein Bild vorhanden !!! "&_
" "&UV&_
XX&"**********************************"&_
UVW, VbCritical, Titel : WScript.Quit
End If
' Nrn. der Bilder 4 - stellig machen, Bild(i) neu definieren :
' ************************************************************
i=1
Do until i>Zahl
Z4=Left(Right(Bild(i),8),1)
If not (Asc(Z4)>47 and Asc(Z4)<58) then
Fso.MoveFile Bild(i), _
Left(Bild(i),Len(Bild(i))-7)&"0"&Right(Bild(i),7)
Bild(i)=Left(Bild(i),Len(Bild(i))-7)&"0"&Right(Bild(i),7)
End If
i=i+1
Loop
Sortieren 'Bilder mit 4 - stelligen Nrn. neu sortieren
' Neue Nrn(i) der Bilder ermitteln :
' **********************************
i=1
Do until i>Zahl
ReDim Preserve Nrn(i)
Nrn(i)=Left(Right(Bild(i),8),4)
i=i+1
Loop
' Den evtl. gewählten Bereich jetzt überprüfen :
' **********************************************
Ja="2"
If not Zone="" then
Bereich
Ja="0"
i=1
Do until i>Zahl
If CInt(Nrn(i))=CInt(Anfg) then
Ja=1+Ja
Anfg=i
End If
If CInt(Nrn(i))=CInt(Ende) then
Ja=1+Ja
Ende=i
End If
i=i+1
Loop
End If
If Ja<>2 then _
MsgBox UVW&" Der gewählte Bereich war ungeeignet !"&_
UVW, VbCritical, Titel : WScript.Quit
' Festlegungen, falls kein begrenzter Bereich gewählt wurde :
' ***********************************************************
If Zone="" then
Anfg="1"
Ende=Zahl
End If
' Die Bilder werden jetzt neu benannt :
' *************************************
i=1
Do until i>Zahl
Ext=LCase(Right(Bild(i),3))
If (i>CInt(Anfg)-1 and i<1+CInt(Ende)) then _
Fso.MoveFile Bild(i),Pfad&"\"&NN&Nrn(i)&"."&Ext
i=i+1
Loop
' Die Schlussmeldung wird jetzt ausgegeben :
' ******************************************
MsgBox UVW&XX&" Die Dateien wurden umbenannt !"&UVW, , Titel
WScript.Quit 'Abschalten, damit kein Übergang auf 2 Ordner
End Sub
' *************************************************************
Sub NeuName
' Den evtl. gewählten Bereich abstecken und dann überprüfen :
' ***********************************************************
Ja="2"
If not Zone="" then
Ja="0"
i=1
Do until i>Zahl
If CInt(Left(Right(Bild(i),8),4))=CInt(Anfg) then
Ja=1+Ja
Anfg=i
End If
If CInt(Left(Right(Bild(i),8),4))=CInt(Ende) then
Ja=1+Ja
Ende=i
End If
i=i+1
Loop
End If
If Ja<>2 then
MsgBox UVW&" Der gewählte Bereich war ungeeignet !"&_
UVW, VbCritical, Titel : WScript.Quit
End If
i=1
Do until i>Zahl
Ext=LCase(Right(Bild(i),3))
If Weg=1 then Nr=Left(Right(Bild(i),8),4)
If Weg=2 then
If i<10 then Nr="000"&i
If 9<i and i<100 then Nr="00"&i
If 99<i and i<1000 then Nr="0"&i
End If
If (i>CInt(Anfg)-1 and i<1+CInt(Ende)) then
Fso.MoveFile Bild(i),Pfad&"\"&NN&Nr&"."&Ext
End If
i=i+1
Loop
' Eine Schlussmeldung wird jetzt ausgegeben :
' *******************************************
MsgBox UVW&XX&" Die Dateien wurden umbenannt !"&UVW, , Titel
WScript.Quit 'Abschalten,damit kein Übergang auf 2. Ordner
End Sub
End If ' Ende vom 1. Programm
' §§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§
' Das 2. Programm, das die Bilder zweier Ordner zeitlich sortiert !
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
' Die Anfangs - Eingaben in alle einzelne Bestandteile unterteilen:
' *****************************************************************
Zahl=Split(Wort2,"#")
' Die Anfangs - Eingaben definieren und genauestens kontrollieren :
' *****************************************************************
Namen=Zahl(0)
Kameras=Zahl(1)
Anders=Zahl(2)
If Len(Kameras)>2 then MsgBox UV&_
"Die Kamera-Namen wurden falsch eingegeben !"&UV, _
VbCritical, Titel : WScript.Quit
' Die Kontrolle der eingebenen Zeitverschiebung, diese ist wichtig!
' *****************************************************************
If not Anders="0" then
Warnung=UV&UV&"Die Zeitverschiebung wurde falsch angegeben !"&UV&UV
Testen=""
For i=1 to Len(Anders) ' " : " in den Zeiten herausnehmen!
If Mid(Anders,i,1)=":" then
Testen=Testen&""
else
Testen=Testen&Mid(Anders,i,1)
End If
Next
' In der Zeit nur Zahlen enthalten und auch sonst alles sinnvoll ?
' ****************************************************************
For i=1 to Len(Testen)
If not (Asc(Mid(Testen,i,1))>=48 and Asc(Mid(Testen,i,1))<=57) _
then MsgBox Warnung, VbCritical, Titel : WScript.Quit
Next
If Left(Right(Anders,3),1)<>":" then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Right(Anders,2)>59 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If (Len(Anders)>=6 and Left(Right(Anders,6),1)<>":") then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)>=5 then _
If Left(Right(Anders,5),2)>59 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If (Len(Anders)>=9 and Left(Right(Anders,9),1)<>":") then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)>=8 then _
If Left(Right(Anders,8),2)>23 then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Left(Anders,1)=":" then _
MsgBox Warnung, VbCritical, Titel : WScript.Quit
If Len(Anders)=11 and Left(Anders,2)>28 then _
MsgBox UV&UV&"Die Anzahl der Tage "&_
"ist zu groß gewählt worden !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Eine Kontrollmeldung aller der vorhin getätigten Vor-Auswahlen :
' ****************************************************************
Satz=Satz&UV&VbCR&"Folgende Angaben wurden bisher eingetragen"
Satz=Satz&VbCR&"*************************************"
Satz=Satz&UV&"Vor alle Bilder kommt der gemeinsame Name :"&VbCR
If Namen="0" then
Satz=Satz&"Es wird kein Name davor gesetzt !"
else
Satz=Satz&Namen
End If
Satz=Satz&UV&"Angehängte Kamera - Namen sollen werden:"&VbCR
If Kameras="0" then
Satz=Satz&"Der Kamera-Name wird nicht angehängt !"
else
Satz=Satz&""" "&Left(Kameras,1)&" "" für die 1., "" "
Satz=Satz&Right(Kameras,1)&" "" bei der 2. Kamera "
End If
Satz=Satz&UV&"Der Zeitvorsprung der 2. Kamera, der beim"&VbCR
Satz=Satz&"Sortieren berücksichtigt werden soll, beträgt:"&VbCR
Satz=Satz&Anders&" ( Tag : Std : Min : Sek )"&UV&UV
Test=MsgBox( Satz, VbInformation + VbOkCancel, Titel )
If Test="2" then WScript.Quit
' *******************************************************************
' Die MsgBox zum Vorstellen der weiteren Anfragen dieses Programmes :
' *******************************************************************
Msg=MsgBox (UV&VbCR&VbTab&"Bitte gleich zwei Ordner"&_
" mit den originalen Bildern "&UV&VbTab&_
"aussuchen, deren Bilder zeitlich passend ineinander"&UV&_
VbTab&"sortiert werden dem Aufnahmedatum entsprechend!"&UV&_
VbTab&"Bei Zeitverschiebung, ""frühere"" Kamera erst nennen!"&UV&_
VbTab&"Alles wird im später gewählten Ordner gespeichert !"&_
UV&VbTab&"Wenn dort der Platz nicht reicht, wird nachgefragt !"&_
UV&UV, VbOkCancel, Titel)
If Msg="2" then
If Fso.FileExists(Datei1) then Fso.DeleteFile Datei1
WScript.Quit
End If
' ****************************************************************
' * Den 1. Bild - Ordner jetzt in folgendem Browser aussuchen : *
' ****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den 1. Bildordner aussuchen !"&_
" "&_
UV&UV, 3, Titel, VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder ( 0, StrPrompt, BrowseInfo, Root)
On Error Resume Next
Err.Clear
Pfad1=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Alle Dateien in dem Ordner 1 zählen und danach durchprüfen :
' ************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
Zahl1="0"
Endg="0"
For each i in Data
Zahl1=1+Zahl1
Summe=Summe+i.Size 'Summierung der Dateigrößen
Ende=LCase(Right(i,3))
If not (Ende="jpg" or Ende="raw") then Endg="1"
Next
If Zahl1="0" then
MsgBox UV&UV&"Der Ordner "&Pfad1&" ist leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
If Endg="1" then
MsgBox UV&UV&"Der Ordner "&Pfad1&_
" enthält nicht nur Bilder !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'******************************************************************
'* Prüfen, ob im Ordner 1 mehr als 6 Bilder / Sek. vorliegen : *
'* Für diese Bilder die Zeit(k) = Tag&Std&Min&Sek feststellen ! *
'******************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
ReDim Preserve Zeit(Zahl1)
k=1 'Für die Zeit(k)
For each i in Data
Name=Left(i.DateLastModified,19)
Tag=Left(Name,2) 'Tag der Aufnahme ermitteln!
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2) 'Std der Aufnahme ermitteln!
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2) 'Sek der Aufnahme ermitteln!
Zeit(k)=Jahr&Monat&Tag&Std&Min&Sek
k=k+1
Next
' Alle diese "Zeit(k)" ihrem Datum gemäß untereinander sortieren :
' *****************************************************************
For i=1 to Zahl1
For k=i+1 to Zahl1
If Zeit(i)>Zeit(k) then
xyz=Zeit(i)
Zeit(i)=Zeit(k)
Zeit(k)=xyz
End if
Next
Next
' Kontrolle, wie oft die gleiche Zeit(k) und ggf. eine Warnmeldung :
' ******************************************************************
Sammel="1"
For i=1 to Zahl1
If i>1 then
If Zeit(i)=Zeit(i-1) then Sammel=Sammel+1
If Zeit(i)<>Zeit(i-1) then Sammel="1" 'Neuanfang
If Sammel>6 then
MsgBox UV&UV&_
"Im Ordner "" "&Pfad1&" "" sind mehr als 6 Bilder / Sek. !"&_
UV&"Eines dieser Kette ist Bild "&i&" !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
End If
Next
'****************************************************************
'* Den 2. Bild - Ordner jetzt in folgendem Browser aussuchen : *
'****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den 2. Bildordner aussuchen !"&_
" "&_
UV&UV, 3, Titel, VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad2=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Alle Dateien in dem Ordner 2 zählen und danach überprüfen :
' ***********************************************************
Set Data=Fso.GetFolder(Pfad2).Files
Zahl2="0"
Endg="0"
For each i in Data
Zahl2=1+Zahl2
Summe=Summe+i.Size 'Summierung der Dateigrößen
Ende=LCase(Right(i,3))
If not (Ende="jpg" or Ende="raw") then Endg="1"
Next
If Zahl2="0" then
MsgBox UV&UV&"Der Ordner "&Pfad2&" ist leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
If Endg="1" then
MsgBox UV&UV&"Der Ordner "&_
Pfad2&" enthält nicht nur Bilder !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Sind diese beiden Ordner 1 und 2 tatsächlich verschieden ?
' **********************************************************
If Pfad1=Pfad2 then
MsgBox UV&UV&_
"Es wurden nicht zwei verschiedene Ordner ausgewählt !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'******************************************************************
'* Prüfen, ob im Ordner 2 mehr als 6 Bilder / Sek. vorliegen : *
'* Für diese Bilder die Zeit(k) = Tag&Std&Min&Sek feststellen ! *
'******************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
ReDim Preserve Zeit(Zahl2)
k=1 'Für die Zeit(k)
For each i in Data
' ************************************
Name=Left(i.DateLastModified,19)
Tag=Left(Name,2) 'Tag der Aufnahme ermitteln!
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2) 'Sek der Aufnahme ermitteln!
Zeit(k)=Jahr&Monat&Tag&Std&Min&Sek
k=k+1
Next
' Alle diese "Zeit(k)" ihrem Datum gemäß untereinander sortieren :
' *****************************************************************
For i=1 to Zahl2
For k=i+1 to Zahl2
If Zeit(i)>Zeit(k) then
xyz=Zeit(i)
Zeit(i)=Zeit(k)
Zeit(k)=xyz
End if
Next
Next
' Eine Kontrolle, wie oft gleiche "Zeit(k)" und ggf. Warnmeldung :
' *****************************************************************
Sammel="1"
For i=1 to Zahl2
If i>1 then
If Zeit(i)=Zeit(i-1) then Sammel=Sammel+1
If Zeit(i)<>Zeit(i-1) then Sammel="1" 'Neuanfang
If Sammel>6 then
MsgBox UV&UV&_
"Im Ordner "" "&Pfad2&" "" sind mehr als 6 Bilder / Sek. !"&_
UV&"Eines dieser Kette ist Bild "&i&" !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
End If
Next
' ************************************
' Zum Abschluss einen Ziel- Ordner für sämtliche Bilder aussuchen :
' *****************************************************************
Wss.Popup UV&UV&VbTab&_
"Bitte den Zielordner der Bilder aussuchen !"&_
" "&_
UV&UV,3,Titel,VbInformation
Set Shl=CreateObject("Shell.Application")
Set ObF=Shl.BrowseForFolder( 0, StrPrompt, BrowseInfo, Root )
On Error Resume Next
Err.Clear
Pfad3=ObF.Self.Path
If Err.Number<>0 then WScript.Quit
Set All=Nothing
' Prüfen, ob der geplante Zielordner wirklich noch völlig leer ist:
' *****************************************************************
Set Data=Fso.GetFolder(Pfad3).Files
Zahl3="0"
For each i in Data
Zahl3=1+Zahl3
Next
If Zahl3>0 then
MsgBox UV&UV&"Der Ordner "&Pfad3&" ist nicht leer !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
' Prüfen, ob der Zielordner von beiden bisherigen verschieden ist :
' *****************************************************************
If (Pfad3=Pfad1 or Pfad3=Pfad2) then
MsgBox UV&UV&"Die Ordner sind leider nicht verschieden !"&_
" "&UV&UV, VbCritical, Titel : WScript.Quit
End If
'*******************************************************************
'* Die Festplatte "X:\" analysieren, ob genügend Platz da, und *
'* Nachfrage, wenn die benannte Platte nicht genügend Platz hat: *
'*******************************************************************
Ziel=Left(Pfad3,2) 'Die Ziel-Festplatte ermitteln
For each k in Lwk
If k=Ziel then
If k.FreeSpace<Summe+300000000 then '300 MB Rest lassen !
Pfad3=InputBox ( UV&UV&"Das Speichermedium "&_
k&"\ hat nicht genug"&_
UV&"Restanteil an Platz ! ! Bestimmen Sie unten "&_
UV&"den Speicherplatz für sämtliche Bilder neu !"&UV&_
UV, Titel, "F:\Bilder\Gemixt" )
End If
End If
Next
' Eine Kontrollmeldung aller dieser getätigten Ordner - Auswahlen :
' *****************************************************************
Test=MsgBox(UV&"Folgende beiden Bild - Ordner :"&VbCR&Pfad1&_
VbCR&Pfad2&UV&"wurden zum Einsortieren ausgesucht !"&UV&_
"Erneut, aber durchsortiert finden sich die Bilder in:"&VBCR&_
Pfad3&UV&VbCR, VbOkCancel, Titel)
If Test="2" then WScript.Quit
' Sollen alle diese Bilder einen Namen vor deren Nrn. bekommen ?
' ****************************************************************
If Namen="0" then Namen="" 'Keinen Namen vorweg !
' An alle diese Bilder die " Namen " der beiden Kameras anhängen ?
' ****************************************************************
Foto=Kameras
Foto1=""
Foto2=""
If Foto<>"0" then Foto1=Left(Foto,1)
If Foto<>"0" then Foto2=Right(Foto,1)
If Foto="0" then Foto="" 'Keinen Namen anhängen !
' Bei Zeitverschiebung beider Kameras die Verschiebung bestimmen !
' ****************************************************************
If Anders<>"0" then
Tag1="00"
Std1="00"
Min1="00"
Sek1="00"
If Len(Anders)<=5 then
Stelle=InStr(Anders,":")
Min1=Left(Anders,Stelle-1)
Sek1=Right(Anders,2)
End If
If (Len(Anders)>6 and Len(Anders)<=8) then
Std1=Left(Anders,Len(Anders)-6)
Min1=Left(Right(Anders,5),2)
Sek1=Right(Anders,2)
End If
If Len(Anders)>9 then
Stelle=InStr(Anders,":")
Tag1=Left(Anders,Stelle-1)
Std1=Left(Right(Anders,8),2)
Min1=Left(Right(Anders,5),2)
Sek1=Right(Anders,2)
End If
End If
If Anders="0" then Anders="" 'Keine Verschiebung nötig !
' Die Frequenz der CPU ermitteln - wegen der Dauer des Programmes :
' *****************************************************************
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\0\~MHz"
Wert0=Wss.RegRead(CheckKey)
'Einen Doppel - Prozessor vorgefunden ?
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\1\~MHz"
Wert1=Wss.RegRead(CheckKey)
'Falls ein Doppel - Prozessor vorliegt :
If not Wert1="" then Wert0=Wert0*2
Zeit=Round((14*(Zahl1+Zahl2)/Wert0),1)
' Ein Hinweis auf eine überlange Dauer bei deutlich vielen Bildern :
' ******************************************************************
If Zahl1+Zahl2>150 then
Wss.Popup UV&UV&"Der Vorgang kann bei "&_
Zahl1+Zahl2&" Bildern ca. "&Zeit&" Min. dauern !"&_
" "&UV&UV, 4, Titel, VbCritical
End If
' Auf Sekunde exaktes Datei - Datum im Ordner 1 als Namen wählen :
'*****************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
For each i in Data 's.u. < ==============
Name=Left(i.DateLastModified,19)
' Tag, Monat, Jahr, Std, Min, Sek sämtlicher Aufnahmen ermitteln:
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
'******************************************************************
'* Falls Kamera 2 eine innere Systemzeit nach der Kamera 1 hat, *
'* müssen die Zeiten der Kamera 1 entsprechend durch Addition *
'* angeglichen werden : Sek, Min, Std, Tag, Monat, Jahr ändern! *
'******************************************************************
If Anders<>"" then
Sek=CInt(Sek)+CInt(Sek1) 'Ohne CInt: Anhängen statt Addition!
If Len(Sek)=1 then Sek="0"&Sek
If Sek>59 then
Sek=Sek-60
Min=Min+1
End If
If Len(Sek)=1 then Sek="0"&Sek
If Len(Min)=1 then Min="0"&Min
' ( Problem: "0" wurde bei Addition einfach weggelassen ! )
Min=CInt(Min)+CInt(Min1) 'Ohne CInt: Anhängen statt Addition!
If Len(Min)=1 then Min="0"&Min
If Min>59 then
Min=Min-60
Std=Std+1
End If
If Len(Min)=1 then Min="0"&Min
If Len(Std)=1 then Std="0"&Std
'( Problem: "0" wurde bei Addition einfach weggelassen ! )
Std=CInt(Std)+CInt(Std1) 'Ohne CInt: Anhängen statt Addition!
If Len(Std)=1 then Std="0"&Std
If Std>23 then
Do until Std<24
Std=Std-24
Tag=Tag+1
Loop
End If
If Len(Std)=1 then Std="0"&Std
If Len(Tag)=1 then Tag="0"&Tag
' ( Problem: "0" wurde bei Addition einfach weggelassen ! )
End If
Tag=CInt(Tag)+CInt(Tag1) 'Ohne CInt: Anhängen statt Addition!
If Len(Tag)=1 then Tag="0"&Tag
If Tag>31 and (Monat="01" or Monat="03" or Monat="05" or _
Monat="07" or Monat="08" or Monat="10" or Monat="12") then
Tag=Tag-31
Monat=CInt(Monat)+1
If Monat="13" then
Monat="01"
Jahr=CInt(Jahr)+1
If Len(Jahr)=1 then Jahr="0"&Jahr
End If
If Len(Tag)=1 then Tag="0"&Tag
If Len(Monat)=1 then Monat="0"&Monat
End If
If Tag>30 and (Monat="04" or Monat="06" _
or Monat="09" or Monat="11") then
Tag=Tag-30
Monat=CInt(Monat)+1
If Len(Tag)=1 then Tag="0"&Tag
If Len(Monat)=1 then Monat="0"&Monat
End If
If Tag>28 and (CInt(Jahr) mod 4<>"0") and Monat="02" then
Tag=Tag-28
Monat="03"
If Len(Tag)=1 then Tag="0"&Tag
End If
If Tag>29 and (CInt(Jahr) mod 4="0") and Monat="02" then
Tag=Tag-29
Monat="03"
If Len(Tag)=1 then Tag="0"&Tag
End If
Endg=LCase(Fso.GetExtensionName(i)) 'Datei - Endung
Name=Jahr&Monat&Tag&Std&Min&Sek&"_1."&Endg
'***************************************************************
'* Bilder des 1. Ordners kopieren mit Namen gemäß der Zeit : *
'* Falls gleicher Zeit- Name schon da, an den neuen gleichen *
'* Namen "1" bis "5" anhängen, wird dann dahinter sortiert ! *
'* Es sind also 6 Bilder pro Sekunde dabei hier eingeplant ! *
'***************************************************************
If not Fso.FileExists (Pfad3&"\"&Name) then
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"1_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"2_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"3_1."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"4_1."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"5_1."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"5_1."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
End If
Next 's.o. < ===============
' Auf Sekunde exaktes Datei - Datum im Ordner 2 als Namen wählen :
' ****************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
For each i in Data 's.u. < ============
Name = Left(i.DateLastModified,19)
' Tag, Monat, Jahr, Std, Min, Sek aller der Aufnahmen ermitteln :
Tag=Left(Name,2)
Monat=Mid(Name,4,2)
Jahr=Mid(Name,7,4)
Std=Mid(Name,12,2)
Min=Mid(Name,15,2)
Sek=Mid(Name,18,2)
Endg=LCase(Fso.GetExtensionName(i)) 'Datei-Endung
Name=Jahr&Monat&Tag&Std&Min&Sek&"_2."&Endg
' Die Bilder des 2. Ordners mit ihren Zeit - Namen hinzu kopieren :
' *****************************************************************
' Falls gleicher Zeit - Name da, an den gleichen Namen
' "A", "B" bis "E" anhängen, wird dahinter sortiert !
' Es sind also 6 Bilder pro Sekunde dabei eingeplant !
If not Fso.FileExists (Pfad3&"\"&Name) then
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
ElseIf (Fso.FileExists (Pfad3&"\"&Name) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"A_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"B_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"C_2."&Endg) and _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"D_2."&Endg) and not _
Fso.FileExists (Pfad3&"\"&_
Jahr&Monat&Tag&Std&Min&Sek&"E_2."&Endg)) then
Name=Jahr&Monat&Tag&Std&Min&Sek&"E_2."&Endg
Fso.CopyFile i,Pfad3&"\"&Name
End If
Next 's.o. < ============
' Alle diese Bilder sammeln, sind vorerst nummeriert nach Auffinden :
' *******************************************************************
Set Ort=Fso.GetFolder(Pfad3).Files
i=1
For each File in Ort
ReDim Preserve Bild(i)
Bild(i)=File
i=i+1
Next
Zahl=i-1
' Alle diese Bilder nach ihrem Datum und der inneren Zeit sortieren :
' *******************************************************************
For i=1 to Zahl
For k=i+1 to Zahl
If Bild(i)>Bild(k) then
xyz=Bild(i)
Bild(i)=Bild(k)
Bild(k)=xyz
End if
Next
Next
' Diese sortierten Bilder neu nummerieren, evtl. einen Namen davor :
' *******************************************************************
i=1
Do until i>Zahl
If i<10 then i="000"&i 'Nr. vierstellig machen
If (i>=10 and i<100) then i="00"&i
If (i>=100 and i<1000) then i="0"&i
If Right(Fso.GetBaseName(Bild(i)),2)="_1" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto1&Right(Bild(i),4)
If Right(Fso.GetBaseName(Bild(i)),2)="_2" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto2&Right(Bild(i),4)
If Foto="" then Fso.MoveFile _
Bild(i), Pfad3&"\"&Namen&i&"_"&Foto2&Right(Bild(i),4)
i=i+1
Loop
' Schluss-Information, dass diese Einsortierung abgeschlossen wurde :
' *******************************************************************
Wss.Popup UV&UV&VbTab&" Das war es ! ! !"&_
" "&UV&UV, 10, Titel, VbInformation
WScript.Quit
#########################################################################
>>> browse-for-file-ie.vbs <<<
'*** v9.B *** www.dieseyer.de ******************************
'
' Datei: browse-for-file-ie.vbs
' Autor: Joseph Morales
' Auf: www.dieseyer.de
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' Unter Win7 / Windows 7 ist es ggf. erforderlich den
' 'Datei öffnen ...' Dialog in den Vordergrung zu holen
Call AppActivateVBS ( "Date" ) ' "Date" sind die ersten Zeichen im Fensternamen
MsgBox ChooseFile, , "016 :: " & WScript.ScriptName
WScript.Quit
'*** v6.B *** www.dieseyer.de ******************************
Function ChooseFile()
'***********************************************************
' aus http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_thread/thread/f00a1c5d856c731f/c1d22782d2816bff?lnk=st&q=Joseph+Morales+Here%27s+the+code+with+the+additions+to+make+things&rnum=1#c1d22782d2816bff
Dim IE : Set IE = CreateObject("InternetExplorer.Application")
ChooseFile = ""
IE.visible = False
IE.Navigate("about:blank")
Do Until IE.ReadyState = 4
' WScript.Sleep 33
Loop
IE.TheaterMode = False
IE.Document.Write "<HTML><BODY><INPUT ID=""Fil""Type=""file""></BODY></HTML>"
IE.height = "0"
IE.width = "0"
IE.visible = True
IE.visible = False
With IE.Document.all.Fil
.focus
.click
ChooseFile = .value
End With
IE.Quit
Set IE = Nothing
End Function 'ChooseFile()
'*** v9.4 *** www.dieseyer.de ******************************
Function UserTempVerz
'***********************************************************
' aus 'Scriptomatic v2.0' by 'The MS Scripting Guys'
Dim Tst
On Error Resume Next
err.Clear
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
MsgBox "Das lokale WMI ist defekt - der PC ist für WinTuC momentan nicht geeignet.", vbCritical + 4096, "062 :: " & Titel
SelfClose = "-NO" ' Unterdrückt die Aktualisierung
self.Close
Exit Function
End If
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Environment", "WQL", &h10 + &h20 )
Dim objItem
For Each objItem In colItems
If InStr( UCase( objItem.UserName ), UCase( CreateObject("WScript.Network").Username ) ) > 0 Then
' If objItem.SystemVariable = vbFalse Then UserTempVerz = objItem.VariableValue : Exit For
If InStr( UCase( objItem.VariableValue ), "TEMP" ) > 0 Then UserTempVerz = objItem.VariableValue : Exit For
If InStr( UCase( objItem.VariableValue ), "TMP" ) > 0 Then UserTempVerz = objItem.VariableValue : Exit For
End If
Next
' MsgBox UserTempVerz, , "077 :: "
If InStr( UCase( UserTempVerz ), "%USERPROFILE%" ) = 1 Then
UserTempVerz = Mid( UserTempVerz, Len( "%USERPROFILE%" ) + 1 )
UserTempVerz = CreateObject("WScript.Shell").Environment("PROCESS")("USERPROFILE") & UserTempVerz
End If
' MsgBox "UserTempVerz: " & UserTempVerz, , "083 :: " : WScript.Quit
End Function ' UserTempVerz
'*** v9.B *** www.dieseyer.de ******************************
Sub AppActivateVBS( ProgrName )
'***********************************************************
' Prozedur Schreibt ein VBS, das eine Anwendung in den
' Vordergrund holt
Dim ListeDatei, Txt, Datei
Datei = UserTempVerz() & "\" & CreateObject("Scripting.FileSystemObject").GetTempName()
Datei = Mid( Datei, 1, InStrRev( Datei, "." ) ) & "vbs"
' MsgBox Datei, , "096 :: "
Txt = ""
Txt = Txt & vbCRLF & "Do"
Txt = Txt & vbCRLF & "i = i + 1"
Txt = Txt & vbCRLF & "WScript.Sleep 33"
Txt = Txt & vbCRLF & "If CreateObject(""WScript.Shell"").AppActivate( ""Date"") Then Exit Do"
' Txt = Txt & vbCRLF & "WScript.Quit"
Txt = Txt & vbCRLF & "Loop"
' Txt = Txt & vbCRLF & "MsgBox i & ""xxxx"", ," & " ""104 :: "" "
CreateObject("Scripting.FileSystemObject").CreateTextFile( Datei ).Write Txt
CreateObject("WScript.Shell").Run "wscript.exe """ & Datei & """", , False
' CreateObject("WScript.Shell").Run "notepad """ & Datei & """", , False
End Sub ' AppActivateVBS( ProgrName )
#########################################################################
>>> browse-for-file.vbs <<<
'*** v6.C *** www.dieseyer.de ******************************
'
' Datei: browse-for-file.vbs
' Autor: ? ? ?
' Auf: www.dieseyer.de
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox BFF, , WScript.ScriptName
WSCript.Quit
'*** v9.B *** www.dieseyer.de ******************************
Function BFFStartVerzeichnis( Verz )
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
' unter Win7 / Windows 7 nicht verfügbar:
' http://technet.microsoft.com/en-us/magazine/2008.08.heyscriptingguy.aspx
' man nehme browse-for-file-ie.vbs
Dim Dialog : Set Dialog = CreateObject("UserAccounts.CommonDialog")
' Dialog.Filter = "Text Files|*.txt|All Files|*.*" ' zeigt nur *.txt
' Dialog.Filter = "Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*" ' zeigt nur *.xls
Dialog.Filter = "Alle Dateien|*.*" ' zeigt nur *.* - also ALLES
' Dialog.Filter = "Textdateien|*.txt|Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*"
Dialog.FilterIndex = 2 ' von den drei auswählbaren Filtern wird der 2. eingesetzt
Dialog.InitialDir = Verz
Dialog.ShowOpen
BFFStartVerzeichnis = Dialog.FileName
End Function ' BFFStartVerzeichnis( Verz )
'*** v6.C *** www.dieseyer.de ******************************
Function BFF()
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
Dim Dialog : Set Dialog = CreateObject("UserAccounts.CommonDialog")
' Dialog.Filter = "Text Files|*.txt|All Files|*.*" ' zeigt nur *.txt
' Dialog.Filter = "Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*" ' zeigt nur *.xls
Dialog.Filter = "Alle Dateien|*.*" ' zeigt nur *.* - also ALLES
' Dialog.Filter = "Textdateien|*.txt|Excel-Arbeitsmappen|*.xls|Alle Dateien|*.*"
Dialog.FilterIndex = 2 ' von den drei auswählbaren Filtern wird der 2. eingesetzt
Dialog.ShowOpen
BFF = Dialog.FileName
End Function ' BFF()
#########################################################################
>>> browse-for-folder-1.vbs <<<
' http://www.source-center.de/forum/member.php?u=2469
strVerz = CreateObject( "Shell.Application" ).BrowseForFolder( 0, "Ordner auswählen", 22, 17 ).Items().Item().Path
MsgBox strVerz, , WScript.ScriptName
#########################################################################
>>> browse-for-folder.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' Datei: browse-for-folder.vbs
' Autor: ? ? ?
' Auf: www.dieseyer.de
'
' Zeigt sehr viele Möglichkeiten, wie man mit VBS eine Datei-
' bzw. Verzeichnisauswahl realisieren kann.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox BrowseForFolder( "Verzeichnis auswählen:", 9+16384, 0 ), , WScript.ScriptName
WScript.Quit
'*** v9.4 *** www.dieseyer.de ******************************
Function BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'***********************************************************
' http://www.codecomments.com/message367170.html
' http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_frm/thread/f083a8d1806e9a68/d835b2a1ec45afec?lnk=st&q=BrowseForFolder+strPrompt+intBrowseInfo+vRootFolder&rnum=1&hl=de#d835b2a1ec45afec
'
'BrowseForFolder dialog. Follows MSDN example closely. Also handles selection of special
'folders (ex Desktop), which do not return a folder3 object as 'normal' folders do.
'Code below does not support all options, only folders.
'To use, copy and paste function into script,
'call as BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder) where root folder is either an
'integer (constants below) or a string with a folder path.
'To use the constants below, they must be in the script header.
'Flags specifying the options for the dialog box. This member can include zero or a combination of the following values.
Const BIF_BROWSEFORCOMPUTER = 4096 'Only return computers. If the user selects anything other than a computer, the OK button is grayed.
Const BIF_BROWSEFORPRINTER = 8192 'Only allow the selection of printers. If the user selects anything other than a printer, the OK button is grayed. In Microsoft Windows XP, the best practice is to use an XP-style dialog, setting the root of the dialog to the Printers and Faxes folder (CSIDL_PRINTERS).
Const BIF_BROWSEINCLUDEFILES = 16384 'Version 4.71. The browse dialog box will display files as well as folders.
'Const BIF_BROWSEINCLUDEURLS = 'Version 5.0. The browse dialog box can display URLs. The BIF_USENEWUI and BIF_BROWSEINCLUDEFILES flags must also be set. If these three flags are not set, the browser dialog box will reject URLs. Even when these flags are set, the browse dialog box will only display URLs if the folder that contains the selected item supports them. When the folder's IShellFolder::GetAttributesOf method is called to request the selected item's attributes, the folder must set the SFGAO_FOLDER attribute flag. Otherwise, the browse dialog box will not display the URL.
Const BIF_DONTGOBELOWDOMAIN = 2 'Do not include network folders below the domain level in the dialog box's tree view control.
Const BIF_EDITBOX = 16 'Version 4.71. Include an edit control in the browse dialog box that allows the user to type the name of an item.
'Const BIF_NEWDIALOGSTYLE = 'Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_NONEWFOLDERBUTTON = 512 'Version 6.0. Do not include the New Folder button in the browse dialog box.
'Const BIF_NOTRANSLATETARGETS = 'Version 6.0. When the selected item is a shortcut, return the PIDL of the shortcut itself rather than its target.
Const BIF_RETURNFSANCESTORS = 8 'Only return file system ancestors. An ancestor is a subfolder that is beneath the root folder in the namespace hierarchy. If the user selects an ancestor of the root folder that is not part of the file system, the OK button is grayed. Const BIF_RETURNONLYFSDIRS = 1 'Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
'Const BIF_SHAREABLE = 'Version 5.0. The browse dialog box can display shareable resources on remote systems. It is intended for applications that want to expose remote shares on a local system. The BIF_NEWDIALOGSTYLE flag must also be set.
Const BIF_STATUSTEXT = 4 'Include a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. This flag is not supported when BIF_NEWDIALOGSTYLE is specified.
'Const BIF_UAHINT = 'Version 6.0. When combined with BIF_NEWDIALOGSTYLE, adds a usage hint to the dialog box in place of the edit box. BIF_EDITBOX overrides this flag.
'Const BIF_USENEWUI = 'Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE. To use BIF_USENEWUI, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_VALIDATE = 32 'Version 4.71. If the user types an invalid name into the edit box, the browse dialog box will call the application's BrowseCallbackProc with the BFFM_VALIDATEFAILED message. This flag is ignored if BIF_EDITBOX is not specified.
Const ssfALTSTARTUP = 29 'File system directory that corresponds to the user's nonlocalized Startup program group. (value = 29)
Const ssfAPPDATA = 26 'Version 4.71. File system directory that serves as a common repository for application-specific data. A typical path is C:\Documents and Settings\username\Application Data. (value = 26)
Const ssfBITBUCKET = 10 'Virtual folder containing the objects in the user's Recycle Bin. (value = 15)
Const ssfCOMMONALTSTARTUP = 30 'File system directory that corresponds to the nonlocalized Startup program group for all users. Valid only for Microsoft Windows NT systems. (value = 30)
Const ssfCOMMONAPPDATA = 35 'Version 5.0. Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data. (value = 35)
Const ssfCOMMONDESKTOPDIR = 25 'File system directory that contains files and folders that appear on the desktop for all users. A typical path is C:\Documents and Settings\All Users\Desktop. Valid only for Windows NT systems. (value = 25)
Const ssfCOMMONFAVORITES = 31 'File system directory that serves as a common repository for all users' favorite items. Valid only for Windows NT systems. (value = 31)
Const ssfCOMMONPROGRAMS = 23 'File system directory that contains the directories for the common program groups that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs. Valid only for Windows NT systems. (value = 23)
Const ssfCOMMONSTARTMENU = 22 'File system directory that contains the programs and folders that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu. Valid only for Windows NT systems. (value = 22)
Const ssfCOMMONSTARTUP = 24 'File system directory that contains the programs that appear in the Startup folder for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs\Startup. Valid only for Windows NT systems. (value = 24)
Const ssfCONTROLS = 3 'Virtual folder containing icons for the Control Panel applications. (value = 3)
Const ssfCOOKIES = 33 'File system directory that serves as a common repository for Internet cookies. A typical path is C:\Documents and Settings\username\Cookies. (value = 33)
Const ssfDESKTOP = 0 'Microsoft Windows Desktop—virtual folder that is the root of the namespace. (value = 0)
Const ssfDESKTOPDIRECTORY = 16 'File system directory used to physically store the file objects that are displayed on the desktop. It is not to be confused with the desktop folder itself, which is a virtual folder. A typical path is C:\Documents and Settings\username\Desktop. (value = 16)
Const ssfDRIVES = 17 'My Computer—virtual folder containing everything on the local computer: storage devices, printers, and Control Panel. This folder may also contain mapped network drives. (value = 17)
Const ssfFAVORITES = 6 'File system directory that serves as a common repository for the user's favorite items. A typical path is C:\Documents and Settings\username\Favorites. (value = 6)
Const ssfFONTS = 20 'Virtual folder containing installed fonts. A typical path is C:\WINNT\Fonts. (value = 20)
Const ssfHISTORY = 34 'File system directory that serves as a common repository for Internet history items. (value = 34)
Const ssfINTERNETCACHE = 32 'File system directory that serves as a common repository for temporary Internet files. A typical path is C:\Documents and Settings\username\Temporary Internet Files. (value = 32)
Const ssfLOCALAPPDATA = 28 'Version 5.0. File system directory that serves as a data repository for local (non-roaming) applications. A typical path is C:\Documents and Settings\username\Local Settings\Application Data. (value = 28)
Const ssfMYPICTURES = 39 'My Pictures folder. A typical path is C:\Documents and Settings\username\My Documents\My Pictures. (value = 39)
Const ssfNETHOOD = 19 'A file system folder containing the link objects that may exist in the My Network Places virtual folder. It is not the same as ssfNETWORK, which represents the network namespace root. A typical path is C:\Documents and Settings\username\NetHood. (value = 19)
Const ssfNETWORK = 21 'Network Neighborhood—virtual folder representing the root of the network namespace hierarchy. (value = 18)
Const ssfPERSONAL = 5 'File system directory that serves as a common repository for a user's documents. A typical path is C:\Documents and Settings\username\My Documents. (value = 5)
Const ssfPRINTERS = 4 'Virtual folder containing installed printers. (value = 4)
Const ssfPRINTHOOD = 18 'File system directory that contains the link objects that may exist in the Printers virtual folder. A typical path is C:\Documents and Settings\username\PrintHood. (value = 27)
Const ssfPROFILE = 40 'Version 5.0. User's profile folder. (value = 40)
Const ssfPROGRAMFILES = 38 'Version 5.0. Program Files folder. A typical path is C:\Program Files. (value = 38)
Const ssfPROGRAMS = 2 'File system directory that contains the user's program groups (which are also file system directories). A typical path is C:\Documents and Settings\username\Start Menu\Programs. (value = 2)
Const ssfRECENT = 8 'File system directory that contains the user's most recently used documents. A typical path is C:\Documents and Settings\username\Recent. (value = 8)
Const ssfSENDTO = 9 'File system directory that contains Send To menu items. A typical path is C:\Documents and Settings\username\SendTo. (value = 9)
Const ssfSTARTMENU = 11 'File system directory containing Start menu items. A typical path is C:\Documents and Settings\username\Start Menu. (value = 11)
Const ssfSTARTUP = 7 'File system directory that corresponds to the user's Startup program group. The system starts these programs whenever any user logs onto Windows NT or starts Windows 95. A typical path is C:\Documents and Settings\username\Start Menu\Programs\Startup. (value = 7)
Const ssfSYSTEM = 37 'Version 5.0. System folder. A typical path is C:\WINNT\SYSTEM32. (value = 37)
Const ssfTEMPLATES = 21 'File system directory that serves as a common repository for document templates. (value = 21)
Const ssfWINDOWS = 36 'Version 5.0. Windows directory or SYSROOT. This corresponds to the %windir% or %SYSTEMROOT% environment variables. A typical path is C:\WINNT. (value = 36)
Dim oShell
Dim oFolder
Dim oFolderItem
Dim strPath
Dim oWSHShell
Dim oFSO
Dim bSuccess
Dim errTst
Set oShell = CreateObject("Shell.Application")
Set oWSHShell = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
'syntax: oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [,vRootFolder])
Set oFolder = oShell.BrowseForFolder(&H0, strPrompt, intBrowseInfo, vRootFolder)
On Error Resume Next
'This seems to get a 'normal' folder object from the folder3 object returned by BrowseForFolder
Set oFolderItem = oFolder.Items.Item
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
' MsgBox "Invalid selection; Please try again", , "110 :: " & WScript.ScriptName
Else
'If a special folder (ex. desktop) is selected, object is nothing.
If (oFolderItem Is Nothing) Then
'This is necessary - seems to convert invalid object reference to a string?
strPath = oFolder
Set oFolderItem = oFSO.GetFolder(oWSHShell.SpecialFolders(strPath))
End If
End If
On Error Resume Next
If Not oFSO.FolderExists(oFolderItem.Path) Then
On Error GoTo 0
MsgBox "Invalid selection; Please try again", , "125 :: " & WScript.ScriptName
Else
bSuccess = True
End If
Loop While Not bSuccess
BrowseForFolder = oFolderItem.Path
End Function ' BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
#########################################################################
>>> cd-lw-auf-zu.vbs <<<
Txt = "Jetzt gehts gleich auf . . . "
Set WSHShell = WScript.CreateObject("WScript.Shell")
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 64
set mp = WScript.CreateObject("WMPlayer.OCX")
mp.cdromcollection.item(0).eject
set mp = nothing
Txt = ". . . jetzt ist es auf, das CD-Laufwerk!"
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 16
' WScript.Sleep 10*1000
WScript.CreateObject("WScript.Shell").Popup "Jetzt gehts wieder zu . . . ", 10, WScript.ScriptName, 4096 + 48
WScript.CreateObject("WMPlayer.OCX").cdromcollection.item(0).eject
WScript.CreateObject("WScript.Shell").Popup "Jetzt ist das Laufwerk wieder zu . . . wenn es kein Notebook ist!", 10, WScript.ScriptName, 4096 + 32
#########################################################################
>>> cd-lw-ermitteln.vbs <<<
'*** v5.9 *** www.dieseyer.de *******************************
'
' Datei: cd-lw-ermitteln.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' ermittelt, ob eine best. CD eingelegt ist
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox CDLwTest("SU930"), , WScript.ScriptName
WScript.Quit
'*** v5.9 *** www.dieseyer.de *******************************
Function CDLwTest( Text )
'************************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim DriveList : Set DriveList = fso.Drives
Dim Lw
CDLwTest = "Falsche CD im Laufwerk."
For Each Lw in DriveList
if 4 = Lw.DriveType Then ' CD-Laufwerk
' if 4 = Lw.DriveType Then ' Wechseldatenträger
If Lw.IsReady Then
' If InStr( UCase( Lw.VolumeName ) , UCase( Text ) ) Then CDLwTest = Lw.VolumeName
If InStr( UCase( Lw.VolumeName ) , UCase( Text ) ) Then CDLwTest = Lw.DriveLetter & ":\"
End If
End If
Next
End Function ' Function CDLwTest( Text )
#########################################################################
>>> cd-menu.vbs <<<
'v2.5*****************************************************
' File: cd-menu.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'*********************************************************
Option Explicit
Dim Modus, DriveList, i, RegKey, objAdr, ZielSys, OpSys, Info
Dim ShellLink, LNK, aktCD, CDLw, WSHver, VBver, InfoDatei, LwFrei, LwHDD, LwSum
Dim Titel, Anzeige, Eingabe, aktAusw, Quelle, Ziel, DateiName, DateiNamen, InstDir
Dim Text, TextX, Text1, Text2, Text3, NT_9x, StopStelle, SysLw, FTP, TmpDir
Dim objNet, WSHShell, fso, Param, WSHEnv
InfoDatei = "\auswahl.txt"
Set objNet = WScript.CreateObject("WScript.Network")
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set WSHEnv = WSHShell.Environment("Process")
Set Param = Wscript.Arguments
If Param.Count >= 1 Then Modus = UCase(Param(0))
' ----------------------------------------------
' . . . ein paar Variablen holen
' ----------------------------------------------
' Installationsverzeichnis festlegen: InstDir
' Festplatte mit dem meisten freien Platz ermitteln: LwHDD
' Testen lokalen Eigenschaften: SysLw, TmpDir, VBver, aktCD
' Testen der Windows-Version: ZielSys, OpSys, NT_9x
' nächste Zeile freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CDTest
If Modus = "TEST" Then
Titel = "WSH" & WSHver & " unter " & NT_9x & "/" & OpSys & " (" & aktCD & ")"
Else
Titel = "Auswahlmenü (c) service.cd@gmx.de"
End if
Info = NT_9x & " - OS-Version: " & vbTab & OpSys & vbCRLF
Info = Info & "System Laufwerk: " & vbTab & SysLw & vbCRLF
Info = Info & "CD-Laufwerk: " & vbTab & CDLw & vbCRLF
Info = Info & "Eingelegte CD: " & vbTab & aktCD & vbCRLF
Info = Info & "TMP-Verzeichnis: " & vbTab & TmpDir & vbCRLF
Info = Info & "WSH Version: " & vbTab & WSHver & " / " & VBver & vbCRLF
Info = Info & "Install-Verz.: " & vbTab & InstDir & vbTab & vbTab & LwFrei & " MB frei" & vbCRLF
If Modus = "TEST" Then MsgBox Info, vbOKOnly, Titel
' nächste Zeile nicht freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WScript.Quit
' ----------------------------------------------
' WSH-Version testen und ggf. aktualisieren
' ----------------------------------------------
' scriptde.exe für Windows 2000 / XP
' scr56de.exe für Windows 98 / ME / NT4
If WSHver < "2" Then
TextX = ""
Text = CDLw & "\TOOL\WScript.56\scriptde.exe"
If (fso.FileExists(Text)) AND OpSys = "Windows 2000" Then TextX = Text
Text = CDLw & "\TOOL\WScript.56\scr56de.exe"
If (fso.FileExists(Text)) AND not OpSys = "Windows 2000" Then TextX = Text
If not TextX = "" Then
Text = "Auf diesem PC ist z.Z. WindowsScriptHost Version 1.0 (WSH1) installiert" & vbCRLF
Text = Text & "Dieses Programm läuft besser, einfacher, schneller, höher, weiter, breiter . . ." & vbCRLF
Text = Text & "wenn eine neuere Version installiert ist. " & vbCRLF & vbCRLF
Text = Text & "(" & TextX & ")" & vbCRLF & vbCRLF
Text = Text & "Jetzt installieren? (Ist ein Neustart erforderlich?)"
'nächsten VIER Zeilen freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
aktAusw = MsgBox(Text, vbYesNo + vbDefaultButton1 + vbQuestion, Titel)
if aktAusw <> vbNo Then
WSHShell.Run (TextX),,True
End If
End If
End If
' ----------------------------------------------
' Das Hauptmenü:
' ----------------------------------------------
Do
If Modus = "TEST" Then
Titel = "WSH" & WSHver & " unter " & NT_9x & "/" & OpSys & " (" & aktCD & ")"
Else
Titel = "Auswahlmenü (c) service.cd@gmx.de"
End if
Anzeige = " 2 " & vbTAB & "Windows 2000 SP2 installieren." & vbCRLF
Anzeige = Anzeige & " 4 " & vbTAB & "Windows NT4 SP6a installieren." & vbCRLF
Anzeige = Anzeige & " a " & vbTAB & "Acrobat Reader v5 installieren." & vbCRLF
Anzeige = Anzeige & " f " & vbTAB & "F-PROT Virus-Scanner starten." & vbCRLF
Anzeige = Anzeige & " i6" & vbTAB & "InternetExplorer v6 installiern." & vbCRLF
Anzeige = Anzeige & " j " & vbTAB & "JVM für MS IE v6 installiern." & vbCRLF
Anzeige = Anzeige & " m " & vbTAB & "McAfee VirusScan starten." & vbCRLF
Anzeige = Anzeige & " mc" & vbTAB & "McAfee VirusScan Kopieren & starten." & vbCRLF
Anzeige = Anzeige & " o1" & vbTAB & "Office 2000 SR1 installieren." & vbCRLF
Anzeige = Anzeige & " o2" & vbTAB & "Office 2000 SR1 SP2 installieren." & vbCRLF
Anzeige = Anzeige & " v " & vbTAB & "VC, WinRAR ... kopieren." & vbCRLF
Anzeige = Anzeige & " w " & vbTAB & "Windows Commander starten." & vbCRLF
Anzeige = Anzeige & " wc" & vbTAB & "Windows Commander kopieren & starten." & vbCRLF
If (fso.FileExists(CDLw & InfoDatei)) Then Anzeige = Anzeige & " . . . was soll's denn sein? (h => Hilfe/Info's)"
If not (fso.FileExists(CDLw & InfoDatei)) Then Anzeige = Anzeige & " . . . was soll's denn sein?"
Eingabe = InputBox(Anzeige,Titel,,500,1)
If Eingabe = "" Then ' Abbruch vom Benutzer
' aktAusw = MsgBox(". . . wirklich beenden?", vbYesNo + vbDefaultButton1 + vbQuestion, Titel)
aktAusw = MsgBox(". . . wirklich beenden?", vbYesNo + vbDefaultButton2 + vbQuestion, Titel)
if aktAusw <> vbNo Then WScript.Quit
End If
If UCase(Eingabe) = "TEST" AND Modus = "" Then Modus = "TEST"
If UCase(Eingabe) = "NOTEST" AND Modus = "TEST" Then Modus = ""
If UCase(Eingabe) = "-TEST" AND Modus = "TEST" Then Modus = ""
If Eingabe = "?" Then MsgBox Info, vbOKOnly, Titel
If Eingabe = "ß" Then MsgBox Info, vbOKOnly, Titel
If Eingabe = "2" Then
TextX = CDLw & "\W2kSp2\W2KSP2.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If Eingabe = "4" Then
TextX = CDLw & "\NT4_SP6A\SP6I386.EXE"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "A" Then
TextX = CDLw & "\TOOL\AcroRead\ar500deu.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "F" Then FProtCopy
If UCase(Eingabe) = "H" Then
TextX = CDLw & InfoDatei
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX)
End If
If UCase(Eingabe) = "I6" Then
TextX = CDLw & "\TOOL\ie6\ie6setup.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "J" Then
TextX = CDLw & "\TOOL\WinXX\JVM\msjavx86.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "M" Then
If NT_9x = "NT" Then TextX = CDLw & "\MCAFEE_4.DOS\ScanNT.BAT"
If NT_9x = "9x" Then TextX = CDLw & "\MCAFEE_4.DOS\Scan9x.BAT"
ExeRun
End If
If UCase(Eingabe) = "MC" Then McAfeeCopy
If UCase(Eingabe) = "MI" Then McAfeeCopy
If UCase(Eingabe) = "O1" Then
TextX = CDLw & "\TOOL\O2kSR1\o2ksr1adl.exe"
If (fso.FileExists(TextX)) Then
Ziel = TmpDir & "\o2ksr1"
If (fso.FolderExists(Ziel)) Then fso.DeleteFolder(Ziel), True
WSHShell.Run (TextX & " /T:" & Ziel),,TRUE
TextX = Ziel & "\setup.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
End If
If UCase(Eingabe) = "O2" Then
TextX = CDLw & "\TOOL\Office.2k\O2kSR1Sp2\sp2upd.exe"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX),,TRUE
End If
If UCase(Eingabe) = "V" Then VCcopy
If UCase(Eingabe) = "W" Then
TextX = CDLw & "\WinCMD\WINCMD32.EXE"
If not (fso.FileExists(TextX)) Then MsgBox "Fehler!" & vbCRLF & vbCRLF & "Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
If (fso.FileExists(TextX)) Then WSHShell.Run (TextX)
End If
If UCase(Eingabe) = "WC" Then WinCMDcopy
If UCase(Eingabe) = "WI" Then WinCMDcopy
If UCase(Eingabe) = "X" Then WScript.Quit
Loop
Sub VCcopy
' ----------------------------------------------
' DateienListe holen und löschen
' ----------------------------------------------
' Zuerst wird die Liste der zu kopierenden Dateien (Quelle) geholt,
' um dann im Zielverzeichnis genau diese Dateien zu löschen.
' Dadurch gibt es keine Probleme beim überschreiben beim Kopiervorgang.
Quelle = CDLw & "\DISKS\win_pc\win_pc"
If not (fso.FolderExists(Quelle)) Then
MsgBox "Fehler!" & vbCRLF & vbCRLF & "SubVCcopy: Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Set Quelle = fso.GetFolder(WSHShell.ExpandEnvironmentStrings(Quelle))
Set DateiNamen = Quelle.Files
For Each i In DateiNamen
DateiName = ZielSys & "\" & i.Name
On Error Resume Next
fso.DeleteFile(DateiName), True
On Error GoTo 0
Next
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
fso.CopyFolder Quelle, ZielSys
Anzeige = "VC, WinRAR, WinCMD . . . in's lokale System (" & ZielSys & ") kopieren . . ." & vbCRLF & vbCRLF
Anzeige = Anzeige & ". . . ist erledigt! "
MsgBox Anzeige,, Titel
End Sub ' VCcopy
Sub McAfeeCopy
Quelle = CDLw & "\MCAFEE_4.DOS"
If not (fso.FolderExists(Quelle)) Then ' Quelle vorhanden?
MsgBox "SubMcAfeeCopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Ziel = InstDir & "\MCAFEE_4.DOS"
Ziel = WSHShell.ExpandEnvironmentStrings(Ziel)
If (fso.FolderExists(Ziel)) Then ' Zielverzeichnis löschen, fals vorhanden
If Modus = "TEST" Then MsgBox Ziel & " wird gelöscht",, Titel
fso.DeleteFolder(Ziel), True
End If
fso.CopyFolder Quelle, Ziel ' Quelle ins Zielverzeichnis kopieren
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
' fso.DeleteFile(Ziel & "\clean.dat"), True ' clean.dat löschen - damit kann man Geld verdienen
If NT_9x = "NT" Then TextX = Ziel & "\ScanNT.BAT"
If NT_9x = "9x" Then TextX = Ziel & "\Scan9x.BAT"
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\ma.lnk")
Text1 = "LNK: " & vbTab & WSHShell.CreateShortcut(ZielSys & "\ma.lnk") & vbCRLF
ShellLink.TargetPath = TextX
Text1 = Text1 & "Target: " & vbTab & TextX & vbCRLF
ShellLink.WorkingDirectory = Ziel
Text1 = Text1 & "WorkDir: " & vbTab & Ziel & vbCRLF
ShellLink.Save
If Modus = "TEST" Then MsgBox "Folgende Verknüpfung wurde erstellt: " & vbCRLF & Text1,,Titel
Anzeige = Quelle & " wurde nach " & Ziel & " kopiert!" & vbCRLF & vbCRLF
Anzeige = Anzeige & "McAfee - Scan kann per <Start> <Ausführen> "" ma "" aufgerufen werden."
MsgBox Anzeige,, Titel
WSHShell.Run ("ma")
End Sub ' McAfeeCopy
Sub SuperScanCopy
Quelle = CDLw & "\Tool\SuperScan"
If not (fso.FolderExists(Quelle)) Then ' Quelle vorhanden?
MsgBox "SuperScanCopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Set Quelle = fso.GetFolder(WSHShell.ExpandEnvironmentStrings(Quelle))
Set DateiNamen = Quelle.Files
For Each i In DateiNamen ' Quell-Dateien-Liste
DateiName = ZielSys & "\" & i.Name ' ist Liste der zu löschenden
On Error Resume Next ' Dateien im Zielverzeichnis
' MsgBox Dateiname,,Titel
fso.DeleteFile(DateiName), True
On Error GoTo 0
Next
Ziel = InstDir & "\SuperSc"
Ziel = WSHShell.ExpandEnvironmentStrings(Ziel)
' Zielverzeichnis löschen, fals vorhanden
If (fso.FolderExists(Ziel)) Then fso.DeleteFolder(Ziel), True
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
fso.CopyFolder Quelle, Ziel
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\scanner.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\SS.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\SScan.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\SuperScan.lnk")
ShellLink.TargetPath = Ziel & "\scanner.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Anzeige = Quelle & " wurde nach " & Ziel & " kopiert!" & vbCRLF & vbCRLF
Anzeige = Anzeige & "SuperScan kann per <Start> <Ausführen> "" SScan "" aufgerufen werden."
MsgBox Anzeige,, Titel
WSHShell.Run ("ss")
End Sub ' SuperScanCopy
Sub WinCMDcopy
' ----------------------------------------------
' DateienListe holen und löschen
' ----------------------------------------------
' Zuerst wird die Liste der zu kopierenden Dateien (Quelle) geholt,
' um dann im Zielverzeichnis genau diese Dateien zu löschen.
' Dadurch gibt es keine Probleme beim überschreiben beim Kopiervorgang.
Quelle = CDLw & "\WinCMD"
Ziel = InstDir & "\WinCMD"
If not (fso.FolderExists(Quelle)) Then
MsgBox "SubWinCMDcopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
If Modus = "TEST" Then MsgBox Ziel & " wird gelöscht . . . ",, Titel
If (fso.FolderExists(Ziel)) Then fso.DeleteFolder(Ziel), True
If Modus = "TEST" Then MsgBox Ziel & " ist gelöscht . . . ",, Titel
If Modus = "TEST" Then MsgBox Quelle & " wird jetzt nach " & Ziel & " kopiert!",, Titel
fso.CopyFolder Quelle, Ziel
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\wc.lnk")
ShellLink.TargetPath = Ziel & "\Wincmd32.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\wincmd.lnk")
ShellLink.TargetPath = Ziel & "\Wincmd32.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\wincmd32.lnk")
ShellLink.TargetPath = Ziel & "\Wincmd32.exe"
ShellLink.WorkingDirectory = Left(Ziel, InstrRev(Ziel, "\"))
ShellLink.Save
Anzeige = Quelle & " wurde nach " & Ziel & " kopiert!" & vbCRLF & vbCRLF
Anzeige = Anzeige & "WinCommander kann per <Start> <Ausführen> "" wc "" aufgerufen werden."
MsgBox Anzeige,, Titel
WSHShell.Run ("wc")
End Sub ' WinCMDcopy
Sub FProtCopy
' ----------------------------------------------
' DateienListe holen und löschen
' ----------------------------------------------
' Zuerst wird die Liste der zu kopierenden Dateien (Quelle) geholt,
' um dann im Zielverzeichnis genau diese Dateien zu löschen.
' Dadurch gibt es keine Probleme beim überschreiben beim Kopiervorgang.
Quelle = CDLw & "\F-Prot"
Ziel = InstDir & "\F-Prot"
If not (fso.FolderExists(Quelle)) Then
MsgBox "SubFProtCopy: " & "Fehler!" & vbCRLF & vbCRLF & "Das erforderliche Verzeichnis " & Quelle & " nicht gefunden!", vbOKOnly, Titel
Exit Sub
End If
Set Quelle = fso.GetFolder(WSHShell.ExpandEnvironmentStrings(Quelle))
Set DateiNamen = Quelle.Files
For Each i In DateiNamen
DateiName = Ziel & "\" & i.Name
On Error Resume Next
' MsgBox Dateiname,,Titel
fso.DeleteFile(DateiName), True
On Error GoTo 0
Next
' ----------------------------------------------
' Dateien kopieren
' ----------------------------------------------
If Modus = "TEST" Then MsgBox Quelle & " wurde nach " & Ziel & " kopiert!",, Titel
fso.CopyFolder Quelle, Ziel
' ----------------------------------------------
' Verknüpfung anlegen - erreichbar wegen PATH
' ----------------------------------------------
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\fp.lnk")
ShellLink.TargetPath = Ziel & "\fp.bat"
ShellLink.WorkingDirectory = Ziel
ShellLink.Save
Set ShellLink = WSHShell.CreateShortcut(ZielSys & "\f-prot.lnk")
ShellLink.TargetPath = Ziel & "\fp.bat"
ShellLink.WorkingDirectory = Ziel
ShellLink.Save
If Modus = "TEST" Then MsgBox "Folgende Verknüpfung wurde erstellt: " & vbCRLF & ZielSys & "\f-p.lnk",,Titel
Anzeige = "F-PROT . . . nach " & Ziel & " kopieren . . ." & vbCRLF
Anzeige = Anzeige & ". . . ist erledigt! " & vbCRLF & vbCRLF
Anzeige = Anzeige & "F-PROT wird jetzt gestartet! "
MsgBox Anzeige,, Titel
WSHShell.Run ("fp")
End Sub ' FProtCopy
Sub ExeRun
' ----------------------------------------------
' *.exe - Datei ausführen
' ----------------------------------------------
' Es wird ein Verknüpfung %TMP%\?????.lnk erstellt, die zusätzlich
' das Arbeitsverzeichnis enthält - manche Programme laufen sonst nicht
If not (fso.FileExists(TextX)) Then
MsgBox "Fehler!" & vbCRLF & vbCRLF & "SubExeRun: Die erforderliche Datei " & TextX & " existiert nicht!", vbOKOnly, Titel
Exit Sub
End If
LNK = Mid(TextX, (InstrRev(TextX, "\")+1))
LNK = Left( LNK, (Instr(LNK, ".")-1))
If Modus = "TEST" Then MsgBox "SubExeRUN erstellt folgenden Link und ruft ihn auf: " & vbCRLF & LNK,,Titel
Text = TmpDir & "\" & LNK
If (fso.FileExists(Text & ".pif")) Then
fso.DeleteFile(Text & ".pif"), True
If Modus = "TEST" Then MsgBox Text & ".pif . . . gelöscht!" ,,Titel
End If
If (fso.FileExists(Text & ".lnk")) Then
fso.DeleteFile(Text & ".lnk"), True
If Modus = "TEST" Then MsgBox Text & ".lnk . . . gelöscht!",,Titel
End If
If (fso.FileExists(Text & ".")) Then
fso.DeleteFile(Text & "."), True
If Modus = "TEST" Then MsgBox Text & ". . . . gelöscht!" ,,Titel
End If
If (fso.FileExists(Text)) Then
fso.DeleteFile(Text), True
If Modus = "TEST" Then MsgBox Text & " . . . gelöscht!" ,,Titel
End If
Set ShellLink = WSHShell.CreateShortcut(Text & ".lnk")
Text1 = "LNK: " & vbTab & WSHShell.CreateShortcut(Text & ".lnk") & vbCRLF
ShellLink.WorkingDirectory = Left(TextX, InstrRev(TextX, "\"))
Text1 = Text1 & "WorkDir: " & vbTab & Left(TextX, InstrRev(TextX, "\")) & vbCRLF
ShellLink.TargetPath = TextX
Text1 = Text1 & "Target: " & vbTab & Left(TextX, InstrRev(TextX, "\")) & vbCRLF
ShellLink.Save
If Modus = "TEST" Then MsgBox "Folgende Verknüpfung wurde erstellt: " & vbCRLF & Text1,,Titel
' Text = Text & ".lnk"
If Modus = "TEST" Then MsgBox Text & vbCRLF & "wird aufgerufen . . .",,Titel
WSHShell.Run Text
' WSHShell.Run (Text),,True ' auf Anwendungsende warten geht nicht immer
' WScript.Sleep 7500 ' geht erst ab WSH2
End Sub ' ExeRun
Sub CDTest
' ---------------------------------------------------------
' Testen der Windows-Version: ZielSys, OpSys, NT_9x
' ---------------------------------------------------------
On Error Resume Next
RegKey = "HKLM\Software\Microsoft\Windows\CurrentVersion\Productname"
TextX = WSHShell.RegRead(RegKey)
If not err.number <> 0 Then
ZielSys = "Command"
OpSys = WSHShell.RegRead(RegKey)
NT_9x = "9x"
End if
On Error GoTo 0
On Error Resume Next
RegKey = "HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion"
TextX = "Windows NT " & WSHShell.RegRead(RegKey)
If not err.number <> 0 Then
ZielSys = "System32"
OpSys = "Windows NT " & WSHShell.RegRead(RegKey)
NT_9x = "NT"
End if
On Error GoTo 0
On Error Resume Next
RegKey = "HKLM\Software\Microsoft\Windows NT\CurrentVersion\Productname"
TextX = WSHShell.RegRead(RegKey)
If not err.number <> 0 Then
ZielSys = "System32"
OpSys = WSHShell.RegRead(RegKey)
NT_9x = "NT"
End if
On Error GoTo 0
Zielsys = WSHShell.ExpandEnvironmentStrings(WSHShell.Environment.Item("WINDIR")) & "\" & ZielSys
' ---------------------------------------------------------
' Lokalen Eigenschaften: SysLw, TmpDir, VBver, aktCD
' ---------------------------------------------------------
CDLw = Left (fso.GetFolder("."), 2) ' CD-Lw.-Buchstabe
aktCD = fso.GetDrive(fso.GetDriveName(CDLw)).VolumeName ' CD-Label
SysLw = Left (WSHEnv ("WINDIR"), 3)
TmpDir = WSHEnv("TEMP")
If TmpDir = "" Then TmpDir = WSHEnv("TMP")
' Unter Win2k ist das Temp-Verz. ?:\Dokumente und Einstellungen\UserName\TEMP
' Wenn TmpDir das ..\UserName\TEMP-Verzeichnis ist und ein ?:\Winnt\TEMP existiert,
' wird TmpDir auf ?:\Winnt\TEMP geändert
if 0 <> InstrRev(TmpDir, objNet.UserName) AND (fso.FolderExists(WSHEnv("SystemRoot") & "\TEMP")) Then TmpDir = WSHEnv("SystemRoot") & "\TEMP"
VBver = WScript.Version
if VBver < "5.1" Then WSHver = "1"
if VBver = "5.1" Then WSHver = "2"
if VBver = "5.6" Then WSHver = "5.6"
if VBver > "5.6" Then WSHver = ">5.6"
' ---------------------------------------------------------
' Festplatte mit dem meisten freien Platz ermitteln: LwHDD
' ---------------------------------------------------------
Set DriveList = fso.Drives
LwFrei = CInt(0)
For Each i in DriveList
if 2 = i.DriveType Then
If i.IsReady Then
If LwFrei < CInt(FormatNumber(i.FreeSpace/1024/1024, 0)) Then
LwFrei = CInt(FormatNumber(i.FreeSpace/1024/1024, 0))
LwHDD = i.DriveLetter & ":"
LwSum = CInt(FormatNumber(i.TotalSize/1024/1024, 0))
End If
End If
End If
Next
' ---------------------------------------------------------
' Installationsverzeichnis festlegen: InstDir
' ---------------------------------------------------------
' Hier werden Dateien abelegt, die für spätere oder wiederholte Installationen
' bzw. Updates erforderlich sind. Nachdem das %TEMP% Verzeichnis als InstDir festgelegt
' wurde, wird zunächst versucht auf dem SystemLaufwerk (meist C:) und anschließend auf
' LwHDD (Festplatte/Partition auf dem System mit dem meisten freien Platz; z.B. D:) ein
' vorhandenes Verzeichnis (setups, setup oder install) zu finden. Existiert ein solches
' Verzeichnis, wird InstDir überschrieben.
If (fso.FolderExists(TmpDir)) Then InstDir = WSHShell.ExpandEnvironmentStrings(TmpDir)
If (fso.FolderExists(SysLw & "setups" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\setups")
If (fso.FolderExists(SysLw & "setup" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\setup")
If (fso.FolderExists(SysLw & "install")) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\install")
If (fso.FolderExists(SysLw & "driver" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\install")
If (fso.FolderExists(SysLw & "treiber")) Then InstDir = WSHShell.ExpandEnvironmentStrings(SysLw & "\install")
If (fso.FolderExists(LwHDD & "\setups" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\setups")
If (fso.FolderExists(LwHDD & "\setup" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\setup")
If (fso.FolderExists(LwHDD & "\install")) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\install")
If (fso.FolderExists(LwHDD & "\driver" )) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\install")
If (fso.FolderExists(LwHDD & "\treiber")) Then InstDir = WSHShell.ExpandEnvironmentStrings(LwHDD & "\install")
If Modus = "TEST" Then MsgBox LwHDD & " ist das Laufwerk mit dem meisten freien Platz: " & LwFrei & " MB von " & LwSum & " MB frei. ", vbOKOnly, Titel
End Sub ' CDTest
#########################################################################
>>> cd-start.vbs <<<
'v3.A**********************************************************
' File: CDstart.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' So startet man automatisch ein Skript durch die
' Autorun-Funktion des (MS-) Betriebssystems
'**************************************************************
'
' Auf der CD müssen sich im Hauptverzeichnis folgende Dateien befinden:
'
' autorun.inf
' ~~~~~~~~~~~
' Inhalt der autorun.inf:
' [autorun]
' open=ShelExec.exe cdstart.vbs
'
' ShelExec.exe (160kBytes)
' ~~~~~~~~~~~~
' von http://www.naughter.com/shelexec.html
'
' cdstart.vbs
' ~~~~~~~~~~~
' Inhalt der cdstart.vbs
' WScript.CreateObject("WScript.Shell").run ("menu.vbs"),0 ,true
' WScript.CreateObject("WScript.Shell").Popup ("Das Menü wird jetzt gestartet . . . "),15
WScript.CreateObject("WScript.Shell").run ("menu.vbs"),0 ,true
' WScript.CreateObject("WScript.Shell").Popup ("Das Menü ist jetzt beendet . . . "),15
#########################################################################
>>> cdauswerfen.vbs <<<
'v3.7*****************************************************
' File: CDauswerfen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
' Nach Info's von Thorsten Gudera, Christoph Basedau
'*********************************************************
Option Explicit
Dim WshShell, fso, ShellApp, DriveList, CDLw, Name, CDex
Dim i, Text
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
' shell32.dll version 4.71 or later
' http://msdn.microsoft.com/library/en-us/shellcc/platform/Shell/reference/objects/folder/copyhere.asp
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME )
Text = "\system32"
If not "Windows_NT" = WScript.CreateObject("WScript.Shell").Environment("Process")("OS") then Text = "\system"
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
Text = fso.GetFileVersion( text ) ' Versionsinfo (der Shell32.dll) holen
' wshshell.Popup "Die Shell32.dll hat die Version " & Text , 3, WScript.ScriptName
Text = Left ( CDbl ( text ), 3 ) ' Versionsinfo formatieren
If Text < 471 then
wshshell.Popup "Es ist ein Shell32.dll mit der Version 4.71 oder höher erforderlich." , 30, WScript.ScriptName & " - Ende"
WScript.Quit
End If
Set DriveList = fso.Drives
For Each i in DriveList
' if 0 = i.DriveType Then Text = "??? " & vbTab & i.DriveLetter & ": " & vbTab
' if 1 = i.DriveType Then Text = "Disk-Lw." & vbTab & i.DriveLetter & ": " & vbTab
' if 2 = i.DriveType Then Text = "Festpl. " & vbTab & i.DriveLetter & ": " & vbTab
' if 4 = i.DriveType Then Text = "CD-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
' if 3 = i.DriveType Then Text = "Netz-Lw." & vbTab & i.DriveLetter & ": " & vbTab
' if 5 = i.DriveType Then Text = "RAM-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
if 4 = i.DriveType Then
CDLw = i.DriveLetter & ":\"
' If i.IsReady Then
Set ShellApp=CreateObject("Shell.Application")
' MsgBox ShellApp.NameSpace(17)
Set Name = ShellApp.NameSpace(17)
' MsgBox Name.ParseName( "F:\" )
' MsgBox Name.ParseName( CDLw )
' Set CDex=Name.ParseName( "F:\" )
Set CDex=Name.ParseName( CDLw )
' CDex.InvokeVerb("Auto&Play") ' WinNT Server engl.
CDex.InvokeVerb("E&ject") ' WinNT Server engl.
CDex.InvokeVerb("Auswerfen")
' MsgBox "1"
CDex.InvokeVerb("&Auswerfen") ' Win2k Prof dt.
' MsgBox "2"
CDex.InvokeVerb("A&uswerfen")
' MsgBox "3"
' End If
End If
Next
MsgBox "Ende ", , WScript.ScriptName
#########################################################################
>>> cddurchsuchen.vbs <<<
'v3.7*****************************************************
' File: CDdurchsuchen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Das Skript sucht nach einem CD-Laufwerk und schreibt
' eine Inhaltsliste, die durchsucht werden kann.
' Oder man zieht eine Datei auf das Skript, die sich dann
' durchsuchen lässt.
'*********************************************************
Option Explicit
Dim WshShell, fso, FileOut, DriveList, i, CDlw
Dim Liste, LstType, Text, objArgs
LstType = ".html"
LstType = ".txt"
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set DriveList = fso.Drives
Set objArgs = WScript.Arguments
For i = 0 to objArgs.Count - 1
Liste = objArgs(i)
Exit For
Next
Set objArgs = nothing
if fso.FileExists( Liste ) then
ListeAnz ( Liste )
End If
For Each i in DriveList
if 4 = i.DriveType AND i.IsReady Then
CDlw = CDlw & vbTab & i.DriveLetter & ":"& vbTab & i.VolumeName & vbCRLF
End If
Next
CDlw = "Die CD-Laufwerke enthalten folgende CD's:" & vbCRLF & vbCRLF & CDlw
CDlw = CDlw & "Von welchem Laufwerk soll eine Inhaltsliste erzeugt werden?"
CDlw = InputBox( CDlw, WScript.ScriptName)
If CDlw = "" then
MsgBox ". . . das ist das Ende!", , Wscript.ScriptName
Wscript.Quit
End If
CDlw = Left( CDlw, 1) & ":"
Set i = fso.GetDrive( CDlw )
if not 4 = i.DriveType OR not i.IsReady Then
MsgBox UCase( CDlw ) & " ist kein CD-Laufwerk!" & vbCRLF & vbCRLF & ". . . das ist das Ende!", , WScript.ScriptName
Wscript.Quit
End If
Liste = i.VolumeName
if not fso.FileExists( Liste & "1" & LstType ) then
Liste = Liste & "1" & LstType
Else
Text = "Zu der CD " & Liste & " in Laufwerk " & UCase( CDlw ) & " existieren folgende Inhaltslisten:" & vbCRLF & vbCRLF
For i = 1 to 9
if fso.FileExists( Liste & i & LstType ) then
Text = Text & Liste & i & LstType & vbCRLF
End If
Next
Text = Text & vbCRLF
Text = Text & "[JA]" & vbTab & " Eine weitere Datei anlegen (notfalls eine Löschen)." & vbCRLF
Text = Text & "[Nein]" & vbTab & " Alle Dateien löschen und eine " & Liste & "1" & LstType & " erstellen." & vbCRLF
Text = MsgBox( Text, 3 + 32, WScript.ScriptName )
if Text = vbCancel then
MsgBox ". . . das ist das Ende!", , Wscript.ScriptName
Wscript.Quit
End If
if Text = vbNo then
For i = 1 to 9
if fso.FileExists( Liste & i & LstType ) then fso.DeleteFile( Liste & i & LstType ), true
Next
Liste = Liste & "1" & LstType
End If
if Text = vbYes then
For i = 9 to 1 Step -1
if not fso.FileExists( Liste & i & LstType ) then Text = i
Next
If Text < 1 then
MsgBox "Es gibt bereits 9 " & Liste & " Dateien - es MUSS gelöscht werden!" & vbCRLF & vbCRLF & ". . . das ist das Ende!", , Wscript.ScriptName
Wscript.Quit
End If
Liste = Liste & Text & LstType
End If
End If
Set FileOut = fso.OpenTextFile( Liste, 8, True)
FileOut.WriteLine Liste & " - Verzeichnis vom " & Now
FileOut.WriteLine " "
FileOut.Close
Set FileOut = nothing
WSHShell.Run "%comspec% /c dir " & CDlw & "\ /s /b >> " & Liste, ,True
ListeAnz ( Liste )
Wscript.Quit
Sub ListeAnz ( Datei )
WSHShell.Run Datei
WScript.Sleep 1000
WshShell.SendKeys ( "^F" )
End Sub
#########################################################################
>>> cdrom-auf-zu.vbs <<<
Txt = "Jetzt gehts gleich auf . . . "
Set WSHShell = WScript.CreateObject("WScript.Shell")
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 64
set mp = WScript.CreateObject("WMPlayer.OCX")
mp.cdromcollection.item(0).eject
set mp = nothing
Txt = ". . . jetzt ist es auf, das CD-Laufwerk!"
WSHShell.Popup Txt, 10, WScript.ScriptName, 4096 + 16
' WScript.Sleep 10*1000
WScript.CreateObject("WScript.Shell").Popup "Jetzt gehts wieder zu . . . ", 10, WScript.ScriptName, 4096 + 48
WScript.CreateObject("WMPlayer.OCX").cdromcollection.item(0).eject
WScript.CreateObject("WScript.Shell").Popup "Jetzt ist das Laufwerk wieder zu . . . wenn es kein Notebook ist!", 10, WScript.ScriptName, 4096 + 32
#########################################################################
>>> changefilenames-imag0001.vbs <<<
'v5.6*************************************************************************************
' File: changefilenames-imag0001.vbs
' Autor: Peter Ladnar, erweitert von Michael Wende
'
' Beschreibung:
' Digitale Bilddateien einer Digicam eines bestimmten Verz. umbennen und neu durchnummerieren
'
' Meine Version geht davon aus, dass die Bilddateien im Digicam Ordner von verschiedenen
' Anlässen, wie Geburtstag, Gartenparty, Urlaub e.t.c. als z.B IMAG0001 bis IMAG0144 vorliegen,
' wobei z.B. IMAG0001 - IMAG0012 Bilddateien vom Geburtstag sind.
' IMAG0013 - IMAG0025 Bilddateien von einer Gartenparty u.s.w.
' Nun können diese Bilddateien eindeutig umbenannt werden. Das Skript ändert bei z.B. Eingabe
' von "0013 - 0025" und "Gartenparty Sommer" die Dateien IMAG0013 - IMAG0025 in
' "Gartenparty Sommer0001" - "Gartenparty Sommer0013" um.
'
'*****************************************************************************************
' Zum Debuggen: script //d name.vbs stop
' Start des Hauptprogrammes **************************************************************
Dim strNewName, objPath, intValue,start,ende,z
Dim songtab(),startzahl,endzahl,h,VonBis,i
Dim ausgabetab(),leni,lenh1,isda
strNewName = Empty
FolderAuswahl
VonBis = InputBox ("Von welcher Datei bis zu welcher Datei umbenennen?","Bitte Ziffern innerhalb der eckigen Klammern max 4stellig eintragen","[0001] - [0012]")
If VonBis = "" Then WScript.Quit
' Hole Start und Endwert als Cstr
start = Mid(VonBis,2,4)
ende = Mid(VonBis,11,4)
' Führende "0" en werden ausgefiltert
startzahl= TrimleadingZeroes(start)
endzahl = TrimleadingZeroes(ende)
' Tabellen mit Werten füllen.
' Die songtab() Tabelle nimmt die Vergleichswerte auf, während die ausgabetab() Tabelle die
' Änderungswerte aufnimmt.
' Beispiel: Geändert werden sollen die Fotodateien Imag0007 - Imag0010
' in BildervonLisa.
' Das Programm erstellt dann BildervonLisa0001 - BilderVonLisa0004
' Gesucht werden Dateiendungen 0007 - 0010 = songtab() Werte
' Geändert werden die Dateien in 0001 - 0004 = ausgabetab() Werte.
For i = Cint(startzahl) To Cint(endzahl)
h = CInt(i) - CInt(startzahl)
leni = Len(i)
lenh1 = Len(h+1)
ReDim Preserve songtab(h+1)
ReDim Preserve ausgabetab(h+1)
Select Case leni
Case 1 songtab(h) = "000" & CStr(i)
Case 2 songtab(h) = "00" & CStr(i)
Case 3 songtab(h) = "0" & CStr(i)
Case Else songtab(h) = CStr(i)
End Select
Select Case lenh1
Case 1 ausgabetab(h) = "000" & CStr(h+1)
Case 2 ausgabetab(h) = "00" & CStr(h+1)
Case 3 ausgabetab(h) = "0" & CStr(h+1)
Case Else ausgabetab(h) = CStr(h+1)
End Select
Next
ShowFolderList objPath ' Hier wird der neue Name eingegeben
For z = Lbound(songtab) to Ubound(songtab)-1 ' Dateien suchen und ändern
ShowFileList objPath,songtab(z),ausgabetab(z)
Next
MsgBox "Alle Dateien umbenannt, fertig ",0,"Digi-Photo Tool, Ende"
' Ende des Hauptprogrammes *****************************************************************
' Start Sub Routinen und Funktionsbeschreibungen *******************************************
Sub FolderAuswahl
isda = EintraginsKontextmenue()
If isda = True then
objPath = CurrentDir ' Für die Einbindung ins Kontextmenü des Windows Explorers.
else
objPath = BrowseForFolder("Ordner mit Bildern auswählen:",&h1, "C:\Eigene Dateien")
End If
End Sub
Sub ShowFolderList(folderspec)
Dim s, x,k
x = 0
s = objPath & ":" & vbCrLf & vbCrLf
For k = Lbound(songtab) to Ubound(songtab)-1
If (x < 10) Then
s = s & songtab(k)
s = s & vbCrLf
x = x+1
End If
Next
If (x = 0) Then
MsgBox "Verzeichnis enthält keine Dateien !! ",0, WScript.Scriptname & " - Ende"
WScript.Quit
End If
s = s & "..." & vbCrLf & "Dateien mit diesem Mustertyp und alle anderen Dateien umbenennen in:"
strNewName = InputBox (s,WScript.Scriptname & " - Neuer Dateiname","Neuen Namen eingeben")
If (IsEmpty(strNewName) = True) Then
WScript.Quit
End If
End Sub
Sub ShowFileList(folderspec,suchmuster,renmuster)
Dim fs, f, f1, fc, zahl
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
If IsinStr(suchmuster, f1) = True Then
RenameFile f1, renmuster
Exit For
End If
Next
End Sub
Function IsinStr(muster, zkette)
Dim regEx, retVal ' Variablen,die ich brauche.
Set regEx = New RegExp ' Regulären Ausdruck erstellen.
regEx.Pattern = muster ' Setze Muster.
regEx.IgnoreCase = True ' Groß-Kleinschreibung ausschalten.
retVal = regEx.Test(zkette) ' Führe Durchsuchung aus.
if retVal Then IsinStr = True Else IsinStr = False
End Function
Function RenameFile(fileName, x)
Dim objFSO, strDest, strName, strExt, strMessage,intValue
strName = "\" & strNewName & x
strExt = Lcase(right(fileName,4))
Select Case strExt
Case ".jpg",".bmp",".gif",".tif"
intValue = 6
Case Else
strMessage = fileName & vbCrLf & "ist keine Bilddatei, trotzdem umbennen?"
intValue = MsgBox(strMessage,4,WScript.Scriptname & " - Keine Bilddatei")
End Select
If (intValue = 7) Then
Exit Function
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDest = objPath & strName & strExt
' If ExistFile(strDest) = False then
objFSO.CopyFile fileName , strDest , OverWriteFiles
objFSO.DeleteFile fileName
' End If
End Function
Function BrowseForFolder(strPrompt, BrowseInfo, root)
On Error Resume Next
Dim objShell, objFolder, intColonPos, objWshShell, returnerror
Set objShell = WScript.CreateObject("Shell.Application")
Set objWshShell = CreateObject("WScript.Shell")
Set objFolder = objShell.BrowseForFolder(&H0, strPrompt, BrowseInfo, root)
BrowseForFolder = objFolder.ParentFolder.ParseName(objFolder.Title).Path
returnerror = err.number
If returnerror <> 0 Then
If returnerror = 424 then
BrowseForFolder = Null
else
intColonPos = InStr(objFolder.Title, ":")
If intColonPos > 0 Then
BrowseForFolder = Mid(objFolder.Title, intColonPos - 1, 2) & "\"
End If
End If
End If
End Function
Function ExistFile(files)
Dim fio, msg
Set fio = CreateObject("Scripting.FileSystemObject")
If (fio.FileExists(files)) Then
ExistFile = True
Else
ExistFile = False
End If
End Function
Function CurrentDir
Dim newfso
Set newfso = WScript.CreateObject("Scripting.FileSystemObject")
CurrentDir = newfso.GetAbsolutePathName(".")
End Function
Function TrimleadingZeroes(mystring)
Dim ind,helpme,erg
erg=""
helpme=""
For ind = 1 To Len(mystring)
helpme = Mid(mystring,ind,1)
If helpme <> "0" Then erg = erg + helpme
If Len(erg) >= 1 And helpme = "0" Then erg = erg + "0"
Next
TrimleadingZeroes = erg
End Function
Function EintraginsKontextmenue()
dim WSHShell, KeyNew, path, kontext,m,asatz
dim KeyToo,Eintrag
Set WSHShell =WScript.CreateObject ("WScript.Shell")
path = WScript.ScriptFullName
kontext = "Bilder umbenennen"
EintraginsKontextmenue = False
KeyNew="HKCR\AllFilesystemObjects\shell\" & kontext & "\command\"
If WSHShell.RegRead(KeyNew) = "" then
Eintrag = InputBox ("Möchten Sie dieses Skript ins Kontextmenü des Explorers einbinden?",vbYesNo)
If Eintrag = vbYes then
WSHShell.RegWrite KeyNew,"wscript " & path
EintraginsKontextmenue = True
MsgBox("Eintrag als *" & kontext & "* wurde neu angelegt.")
End If
Else
EintraginsKontextmenue = True
end if
End Function
' Ende Sub Routinen und Funktionsbeschreibungen *******************************************
#########################################################################
>>> changefilenames.vbs <<<
'v3.5***************************************************
' File: changefilenames.vbs
' Autor: Peter Ladnar
' dieseyer.de
'
' Bilddateien eines Verz. umbennen und durchnummerieren
'*******************************************************
' zum debugen: script //d name.vbs stop
Dim strNewName, objPath, intValue
strNewName = Empty
Begruessung()
FolderAuswahl
ShowFolderList objPath
ShowFileList objPath
MsgBox "Alle Dateien umbenannt, fertig ",0,"Digi-Photo Tool, Ende"
Function Begruessung()
Dim intValue, strMessage
strMessage = "Du hast auch eine digitale Kamera und dich nervt es auch, die Dateinamen" & vbCrLf
strMessage = strMessage & "mühselig manuell in sinnvolle Namen zu ändern?" & vbCrLf & vbCrLf
strMessage = strMessage & "Dann ist dieses Tool genau richtig für dich! "
strMessage = strMessage & "Es benennt alle Dateien eines" & vbCrLf & "wählbaren Verzeichnisses "
strMessage = strMessage & "in einen neuen, durchnummerierten Namen um." & vbCrLf & vbCrLf
strMessage = strMessage & "Tool starten ?"
intValue = MsgBox(strMessage,4, WScript.Scriptname & " - Begrüssung")
If (intValue = 7) Then
WScript.Quit
End If
End Function
Sub FolderAuswahl
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
Const OverWriteFiles = True
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder (WINDOW_HANDLE, "Ordner mit Bildern auswählen:", NO_OPTIONS, "C:\ d:\")
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
End Sub
Sub ShowFolderList(folderspec)
Dim fs, f, f1, fc, s, x
x = 0
s = objPath & ":" & vbCrLf & vbCrLf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
If (x < 10) Then
s = s & f1.name
s = s & vbCrLf
x = x+1
End If
Next
If (x = 0) Then
MsgBox "Verzeichnis enthält keine Dateien !! ",0, WScript.Scriptname & " - Ende"
WScript.Quit
End If
s = s & "..." & vbCrLf & "diese und alle anderen Dateien umbenennen in:"
strNewName = InputBox (s,WScript.Scriptname & " - Neuer Dateiname","NeuerName")
If (IsEmpty(strNewName) = True) Then
WScript.Quit
End If
End Sub
Sub ShowFileList(folderspec)
Dim fs, f, f1, fc, s
s = 1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
RenameFile f1, s
s = s+1
Next
End Sub
Function RenameFile(fileName, x)
Dim objFSO, strDest, strName, strExt, arrLen, intLen, strMessage
arrLen = Array("000","00","0")
strName = "\" & strNewName
strExt = Lcase(right(fileName,4))
intLen = Len(x)
Select Case strExt
Case ".jpg",".bmp",".gif",".tif"
intValue = 6
Case Else
strMessage = fileName & vbCrLf & "ist keine Bilddatei, trotzdem umbennen?"
intValue = MsgBox(strMessage,4,WScript.Scriptname & " - Keine Bilddatei")
End Select
If (intValue = 7) Then
Exit Function
End If
Select Case intLen
Case 1 strName = strName & arrLen(0) & x
Case 2 strName = strName & arrLen(1) & x
Case 3 strName = strName & arrLen(2) & x
Case Else strName = strName & x
End Select
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDest = objPath & strName & strExt
objFSO.CopyFile fileName , strDest , OverWriteFiles
objFSO.DeleteFile fileName
End Function
#########################################################################
>>> chkdsk-defrag.vbs <<<
@echo off
echo j| chkdsk c: /F/R
echo nj| chkdsk d: /F/R
start /w DEFRAG.EXE C: -f
start /w DEFRAG.EXE D: -f
shutdown -r -t 30
#########################################################################
>>> computer-function.vbs <<<
'*** v8.1 *** www.dieseyer.de *******************************
'
' Datei: computer-function.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "Verify Computer Role"
'
'************************************************************
Option Explicit
Dim strComputer
strComputer = WScript.CreateObject("WScript.Network").ComputerName
MsgBox " """ & strComputer & """ ist" & vbCRLF & vbCRLF & ComputerFu( strComputer ), , WScript.ScriptName
WScript.Quit
'*** v8.1 *** www.dieseyer.de ****************************
Function ComputerFu( PCname )
'*********************************************************
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCname & "\root\cimv2")
Dim colComputers : Set colComputers = objWMIService.ExecQuery("Select DomainRole from Win32_ComputerSystem")
Dim objComputer
Dim strComputerRoleTxt
For Each objComputer in colComputers
Select Case objComputer.DomainRole
Case 0
strComputerRoleTxt = "Standalone Workstation"
Case 1
strComputerRoleTxt = "Member Workstation"
Case 2
strComputerRoleTxt = "Standalone Server"
Case 3
strComputerRoleTxt = "Member Server"
Case 4
strComputerRoleTxt = "Backup Domain Controller"
Case 5
strComputerRoleTxt = "Primary Domain Controller"
End Select
ComputerFu = objComputer.DomainRole
Next
ComputerFu = ComputerFu & ": " & strComputerRoleTxt
End Function ' ComputerFu( PCname )
#########################################################################
>>> convert-b4s-to-m3u.vbs <<<
'v5.C===========================================================================================
'
' NAME: convert-b4s-to-m3u.vbs
'
' AUTOR: Michael Wende - wende@helimail.de
' dieseyer.de
' DATUM: 28.12.05
'
' KOMMENTAR: Wandelt in einem angegebenen Ordner alle .4bs Winampplaylistdatei(en)
' in m3u Playlist(en). Die Idee kam mir, als ich einige Winamp Playlisten
' für die Sylvesterparty auf CD brennen wollte. Mir fiel auf, dass ich
' noch einige .b4s Winamp3 Playlisten auf meinem Rechner habe. Mittlerweile
' habe ich Winamp 5 im Einsatz. Zu meinem Entsetzen kann Winamp 5 diese nicht
' abspielen oder konvertieren. Auch mein Brennprogramm Nero kann mit .b4s
' Dateien nichts anfangen. Bei meiner Suche im Internet kam ich auf ein
' Freewaretool "veeXChange" von www.krank.hu. Mein Virenscanner meinte aber,
' dass diese .zip Datei verseucht sei und löschte sie wieder.
' So kam ich auf die Idee, mir ein geeignetes Skript selbst zu schreiben...
'==================================================================================================
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim myxmlstr,myxmlstr2,myxmlstr3
Dim myfsObject,dateiname,m3uFile,textziel
Dim Ordner,Song,Laenge,arg,antwort
Dim strfiles(),vonAnfang,bisEnde,i,anzfiles
Set myfsObject=CreateObject("Scripting.FileSystemObject")
Set oFs=CreateObject("Scripting.FileSystemObject")
arg = BrowseForFile("Bitte Ordner mit .b4s Playlisten auswählen!","Ordnerwahl")
If arg = "" Then
WScript.Quit
End If
If Mid(arg,Len(arg),Len(arg))= "\" then ' Ist Backslash am Ende,dann OK
textziel = arg
Else
textziel = arg & "\" ' sonst Backslash anhängen
End If
Redim strfiles(0)
strfiles(0)=""
anzfiles=0
walkdirs(textziel)
If anzfiles > 0 Then
antwort= MsgBox("Fertig! m3u Playliste(n) wurden erstellt. Möchten Sie jetzt die .b4s Playlisten löschen?",VbYesNo,"Achtung!")
If antwort = VbYes Then
vonAnfang =LBound(strfiles) : bisEnde = UBound(strfiles)
For i=vonAnfang To bisEnde
' MsgBox strfiles(i) & " wird gelöscht!"
oFs.DeleteFile(strfiles(i))
Next
MsgBox "Alle .b4s Winamp3 Playlisten wurden gelöscht!"
End If
Else
MsgBox "Sorry, ich konnte leider keine .b4s Winamp3 Playlisten finden!"
End If
' Ende des Programmes
' ********* Funktionen und Unterprogramme (Subs) **********************************************************
'*********************************************************
Sub walkdirs(arg)
'*********************************************************
If oFs.FolderExists(arg) Then
Set thisDir = oFs.GetFolder(arg)
Set subDirs = thisDir.SubFolders
Set theseFiles = thisDir.Files
If subDirs.Count > 0 Then
For Each dirName in subDirs
walkdirs(dirName)
Next
End If
For Each fileName in theseFiles
If oFs.GetExtensionName(fileName) = "b4s" Then
If strfiles(0) = "" Then
strfiles(0) = fileName
Else
Redim Preserve strfiles(Ubound(strfiles,1) + 1)
strfiles(Ubound(strfiles,1)) = fileName
End If
End If
walkdirs(fileName)
Next
ElseIf oFs.FileExists(arg) Then
If oFs.GetExtensionName(arg) = "b4s" Then
convertFile(arg)
End If
End If
End Sub ' walkdirs(arg)
'*********************************************************
Sub convertFile(fname)
'*********************************************************
'Zur Veranschaulichung konvertiert wird von Beispiel1 nach Beispiel2
'Beispiel1 .b4s Winampplaylist
'<?xml version="1.0" encoding="us-ascii" standalone="yes"?>
'<WinampXML>
' <playlist num_entries="0" label="">
' <entry Playstring="H:\CREAM - Cream Live\01 - CREAM - N.S.U..mp3">
' <Name>CREAM - N.S.U.</Name>
' <Length>615000</Length></entry>
' <entry Playstring="H:\CREAM - Cream Live\02 - CREAM - Sleepy Time Time.mp3">
' <Name>CREAM - Sleepy Time Time</Name>
' <Length>412000</Length></entry>
'
'Beispiel2 .m3u Winampplaylist
'#EXTM3U
'#EXTINF:615,CREAM - N.S.U.
'01 - CREAM - N.S.U..mp3
'#EXTINF:412,CREAM - Sleepy Time Time
'02 - CREAM - Sleepy Time Time.mp3
Dim m3ufile,sMP3,oFS,oFile,oM3U
m3ufile = Left(fname, Len(fname) - 4) & ".m3u" ' = Ausgabedatei
Set oFS = CreateObject("Scripting.FileSystemObject")
Set m3uFile=oFS.CreateTextFile(m3ufile, 1) ' Ausgabedatei öffnen
Set oFile = oFS.GetFile(fname)
Set oM3U = oFile.OpenAsTextStream
m3uFile.WriteLine("#EXTM3U") ' Den Anfang einer .m3u Datei schreiben
anzfiles=anzfiles + 1 ' zähle die Anzahl der .b4s Dateien
Ordner="":Song="":Laenge="" ' Was ich jetzt öfter belege, initialisieren
do while not oM3U.AtEndOfStream ' .b4s Datei lesen und .m3u Datei erstellen
sMP3 = oM3U.ReadLine
If IsinStr("<entry Playstring=", sMP3)= True Then Ordner = stripfromxml(sMP3,"<entry Playstring=",">")
if IsinStr("<Name>", sMP3)= True Then Song = stripfromxml( sMP3,"<Name>","</Name>")
if IsinStr("<Length>", sMP3)= True Then Laenge = stripfromxml( sMP3,"<Length>","</Length>")
' Die 3 relevanten Daten werden aus der .b4s (XML)Datei extrahiert
' und den Variablen Song,Ordner,Laenge übergeben
If Song <> "" And Laenge <> "" Then
Song = HtmlDecode(Song) ' Sonderzeichen der XML .b4s Datei dekodieren
m3uFile.WriteLine "#EXTINF:" & Laenge & ","& Song
Song="" : Laenge = ""
If Ordner <> "" Then
Ordner = Mid(Ordner,2,Len(Ordner)-2)
Ordner = HtmlDecode(Ordner) ' Sonderzeichen der XML .b4s Datei dekodieren
m3uFile.WriteLine Ordner
Ordner=""
End If
End If
Loop
m3uFile.Close
End Sub ' convertFile(fname)
'*********************************************************
Function stripfromxml (xmlstring,xmlpart1,xmlpart2)
'*********************************************************
Dim pos1,pos2,thename
thename=""
pos1 = instr(xmlstring,xmlpart1)
If pos1 Then
thename = mid(xmlstring,pos1+len(xmlpart1),Len(xmlstring))
End If
pos2 = instr(thename,xmlpart2)
If pos2 then thename = mid(thename,1,(pos2)-1)
If xmlpart1="<Length>" then thename = striplastzeroes(thename) ' Länge wird mit 6 Ziffern angegeben, deshalb letzte Nullen löschen
stripfromxml = thename ' das kann zu falschen Songlängen führen. siehe unten.
End Function ' stripfromxml (xmlstring,xmlpart1,xmlpart2)
'*********************************************************
Function BrowseForFile(strPrompt,strtitle)
'*********************************************************
'Benutzt die "Shell.Application" (nur anzutreffen in Win98 and neuer)
'um das Datei/Ordner Fenster aufzurufen. Nicht unter Win95.
'Shell32.ShellSpecialFolderKonstanten
Const ssfPERSONAL = 5 'Meine Dokumente
Const ssfDRIVES = 17 'Mein Computer
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2
Const SFVVO_SHOWFILES = 16384
Dim sh, fol, fs, lngView, strPath,i
Set sh = CreateObject("Shell.Application")
If Instr(TypeName(sh), "Shell") = 0 Then
BrowseForFile = InputBox(strPrompt, strtitle, CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "Pfad\Dateiname")
Exit Function
End If
Set fs = CreateObject("Scripting.FileSystemObject")
lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS Or SFVVO_SHOWFILES
strPath = ""
Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
On Error Resume Next
strPath = fol.ParentFolder.ParseName(fol.Title).Path
If strPath = "" Then
strPath = fol.Title
Set fol = fol.ParentFolder
strPath = fs.BuildPath(fol.ParentFolder.ParseName(fol.Title).Path, strPath)
i = InStr(strPath, ":")
strPath = Mid(strPath, i - 1, 1) & ":\" ' Nur Laufwerk:\ zurückgeben
End If
BrowseForFile = strPath
End Function ' BrowseForFile(strPrompt,strtitle)
'*********************************************************
Function IsinStr(muster, zkette)
'*********************************************************
Dim regEx, retVal ' Variablen,die ich brauche.
Set regEx = New RegExp ' Regulären Ausdruck erstellen.
regEx.Pattern = muster ' Setze Muster.
regEx.IgnoreCase = True ' Groß-Kleinschreibung ausschalten.
retVal = regEx.Test(zkette) ' Führe Durchsuchung aus.
if retVal Then IsinStr = True Else IsinStr = False
End Function ' IsinStr(muster, zkette)
'*********************************************************
public Function HtmlDecode( sText)
'*********************************************************
'Wie in HTML müssen auch in XML Sonderzeichen speziell formatiert werden. Die fünf Zeichen &, ', <, > und "
'werden wie in HTML angegeben:
' ' hex ´ oder '
' & &
' < <
' > >
' " "
'Umlaute und das ß müssen aber so definiert werden:
' Ä Ä hex c4
' Ö Ö hex d6
' Ü Ü hex dc
' ä ä hex e4
' ö ö hex f6
' ü ü hex fc
' ß ß hex df
' € € hex 20ac
' Alles dies erledigt die Function HtmlDecode
sText = Replace(sText, "Ä", "Ä")
sText = Replace(sText, "Ö", "Ö")
sText = Replace(sText, "Ü", "Ü")
sText = Replace(sText, "ä", "ä")
sText = Replace(sText, "ö", "ö")
sText = Replace(sText, "ü", "ü")
sText = Replace(sText, "ß", "ß")
sText = Replace(sText, "€", "€")
sText = Replace(sText, "?", "'")
sText = Replace(sText, "<", "<")
sText = Replace(sText, ">", ">")
'sText = Replace(sText, """, """")
sText = Replace(sText, "$", "$")
sText = Replace(sText, "&", "&")
sText = Replace(sText, "´", "'")
sText = Replace(sText, """, """")
sText = Replace(sText, " ", " ")
sText = Replace(sText, "&bsp;", " ")
HtmlDecode = sText
End Function ' HtmlDecode( sText)
'*********************************************************
Function striplastzeroes(strNumber)
'*********************************************************
' Es kann sein, dass die Songlänge nicht richtig angegeben wird; denn
' in .b4s Playlisten werden 6 Ziffern für die Dateilänge verwendet.
' Ist ein Song 1000 Sekunden lang wird er nach der striplastzeroes Funktion
' auf 100 Sekunden gekürzt. Das ist jedoch nicht so schlimm, wie es scheint,
' da Winamp die falsche Songdauer automatisch korrigert.
Dim MyLong1
MyLong1 = CLng(strNumber)
If (MyLong1 mod 1000) <> 0 Then
striplastzeroes = CStr(Mylong1/100)
Else
striplastzeroes = CStr(Mylong1/1000)
End If
End Function ' striplastzeroes(strNumber)
#########################################################################
>>> copy_mp3_aus_m3u.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: copy_mp3_aus_m3u.vbs
' Autor: Wolfgang Binder
' FamilieBinder@web.de
' Auf: www.dieseyer.de
'
'***********************************************************
'********************************************************************************************
'
'geschrieben für Windows-Script Version 5.6
'
'Dieses Windows-Scrip kopiert MP3-Dateien aus einer M3U-Liste in ein Ziel-Verzeichnis
'dabei kann man per Parameter auswählen ob man die MP3-Dateien
' 1.) Flach alle in das gleiche Verzeichnis
' 2.) Mit Verzeichnis / Unterverzeichnis
' 3.) In ein Register A,B,C,D,...Z, nach dem Dateinamen geordnet
'kopiert. Beim Kopieren werden um Zeit zu sparen nur die noch fehlenden Dateien eingefügt.
'
' Hintergrund war daß ich meine MP3-Dateien zufällig auf meinen Stick kopieren wollte. Zum Erstellen
' der M3U Liste (Zufall) habe ich Winamp verwendet. Danach habe ich mir eine Mulimedia-Festplatte
' gekauft die leider keine M3U Listen verwendet aber viel Platz hat, also habe ich ein Grundverzeichnis
' für meine Musik und kopiere über dieses Script in ein Verzeichnis alle Dateien Flach
'(für Zufallsauswahl der Multimedia-Festplatte) und in ein anderes Verzeichnis alle Musik in ein Register.
'
'Das Script kann etweder über Eingabeparameter oder über die Konstanten gesteuert werden.
'Die einzelnen Konstanten zum Steuern des Scripts sind nachfolgend erklärt, die Eingabeparameter
'für das Script sind bei den Konstanteneinstellungen beschrieben bei Boolschen Variablen werden bei den
'Eingabeparametern anstatt True und False wird 0 und 1 angegeben 0 ==> False, 1 ==> True
'
'Beispiel für Start mit Argumenten
'"Copy_Mp3_aus_M3U.vbs" "/m3u:D:\Install\Musik\Best Of\Pop\Test.m3u" "/Ziel:D:\Temp\3" /Flach:1 /Register:1 /MaxAnzahl:19 /Protokoll:1 /MaxFehler:10 /ProtFile:1
'
'********************************************************************************************
'--------- Konstanteneinstellungen zum Steuern des Scriptes ---------------------------------
'M3U-Datei aus der kopiert werden soll z.B. D:\Install\Musik\Best Of\Pop\aa_Best of Pop_gemischt.m3u
'Eingabeparameter ist: /m3u: Default = ""
Const DATEI_M3U_LIST = "D:\Install\Musik\Best Of\Pop\Test.m3u"
'Lw-Pfad wohin die Mp3-Dateien hin kopiert werden sollen
'Eingabeparameter ist: /Ziel: Default = ""
Const ZIEL_PFAD = "D:\Temp\3"
'True ==> alle MP3-Files werden in das gleiche Ziel-Verzeichnis Kopiert (Ohne Unter-Verzeichnisse)
'False ==> die MP3-Files werden im Zielverzeichnis mit ihren Unter-Verzeichnisse kopiert
'Eingabeparameter ist: /Flach: Default = 0 Bedeutung: 0 = False 1=True
Const FLACH = False
'True ==> alle MP3-Files werden anhand des Dateinamens in ein Register Kopiert (_, A, B, C, D, ...)
'False ==> kein Register
'Eingabeparameter ist: /Flach: Default = 0 Bedeutung: 0 = False 1=True
Const REGISTER = False
'Anzahl der Maximal zu kopierenden Files, bei Angabe von 0 gibt es keine Grenze
'Eingabeparameter ist: /MaxAnzahl: Default = 0
Const MAX_ANZAHL = 0
'nach MAX_ANZAHL_FEHLER_COPY hintereinander fehlerhaften Kopiervorgängen wird abgebrochen.
'Eingabeparameter ist: /MaxFehler: Default = 30
Const MAX_ANZAHL_FEHLER_COPY = 30
'Nicht nur die Fehler sondern auch das kopieren der MP3-Files wird mitprotokolliert
'True ==> es wird protokolliert welche Mp3-Dateien kopiert wurden und welche nicht
'False ==> Mp3-Dateien kopieren wird nicht protokolliert.
'Eingabeparameter ist: /Protokoll: Default = 0 Bedeutung: 0 = False 1=True
Const MP3_PROTOKOLLIEREN = False
'True ==> es wird nicht nur das Protkoll auf dem Bildschirm ausgegeben,
' sondern auch in ein File Protokolliert.Der Name der Log-Datei seht in der
' Konstanten PROTOKOLL_DATEI und wird in das Verzeichnis geschrieben in dem die
' m3u-Datei geöffnet wurde. Im Gesamt Fehlerfall wird das Protoll nicht erzeugt.
'False ==> Protokoll wird nur auf dem Bildschirm ausgegeben.
'Eingabeparameter ist: /ProtFile: Default = 0 Bedeutung: 0 = False 1=True
Const MP3_PROTOKOLL_FILE = False
'Ist WARTEN > 0 wird der Task beim kopieren der MP3-Files für diese Zeiteinheit in Milli Sekunden
'abgegeben. Z.B. WARTEN = 100 dann bedeutet es das der Task für 100 Milli Sekunden abgegeben wird,
'bevor die nächste MP3-Datei kopiert wird.
'Je größer die Zahl desto länger dauert das kopieren der MP3-Files aber,
'man hat keine Schwierigkeiten andere Programme des PC's in dieser Zeit zu verwenden.
'Das kopieren wird ohne Schwierigkeiten für andere Programme im Hintergrund erledigt.
'
'Bei WARTEN = 0 wird der Task nicht abgegeben das kopieren der Files geht am schnellsten.
'Eingabeparameter ist: /Warten: Default = 0
Const WARTEN = 0
'True ==> Das Script kann von einem anderen Programm aufgerufen werden, darum sind die Bildschirmmeldungen
' unterdrückt und der Kopiervorgang wird in der Regestry eingetragen um die Möglichkeit
' zu geben mit einem anderen Programm für dessen Meldungen darauf zuzugreifen.
' Der Regestry-Pfad steht in REG_HAUPTSCHLUESSEL = HKCU\Software\VBScript\CopyMP3ausM3U\ in Run, Ok, Protokoll
'False ==> Kein Regestry-Eintrag und die Bildschirmmeldungen werden ausgegeben.
'Eingabeparameter ist: /Fremd: Default = 0 Bedeutung: 0 = False 1=True
Const FREMD = False
'--------------------------------------------------------------------------------------------
'----------------------Ende Konstanteneinstellungen zum Steuern des Scriptes ----------------
'--- Übergabe -Argumente an das Script (Die Variablennamen zur Übergabe)
Const ARG_DATEI_M3U_LIST = "m3u"
Const ARG_ZIEL_PFAD = "Ziel"
Const ARG_FLACH = "Flach"
Const ARG_REGISTER = "Register"
Const ARG_MAX_ANZAHL = "MaxAnzahl"
Const ARG_MAX_ANZAHL_FEHLER_COPY = "MaxFehler"
Const ARG_MP3_PROTOKOLLIEREN = "Protokoll"
Const ARG_MP3_PROTOKOLL_FILE = "ProtFile"
Const ARG_WARTEN = "Warten"
Const ARG_FREMD = "Fremd"
'-------------------- !!!!!!!!!! A C H T U N G !!! ----------------------------------------
'- -
'- Die weiteren Konstanten stehen nocheinmal in der Hauptfunktion Copy_MP3_Aus_M3U_List -
'- -
'---------------------------------------------------------------------------------------------
'---- für Registrierungsdatenbank ------------------------------------------------------------
Const REG_HKLM = "HKLM" 'HKEY_LOCAL_MACHINE
Const REG_HKCU = "HKCU" 'HKEY_CURRENT_USER
Const REG_HKCR = "HKCR" 'HKEY_CLASSES_ROOT
Const REG_HAUPTSCHLUESSEL = "HKCU\Software\VBScript\CopyMP3ausM3U\"
Const REG_OK = "Ok"
Const REG_RUN = "Run"
Const REG_PROTOKOLL = "Protokoll"
Const REG_FEHLER = "Fehler"
'---- Weitere Konstanten ---------------------------------------------------------------------
Const PROTOKOLL_DATEI = "CopyMp3.log"
'----- Steuervariablen für die an das Script übergebenen Parameter
Dim sArg_m3u
Dim sArg_Ziel
Dim sArg_Flach
Dim sArg_Register
Dim sArg_MaxAnzahl
Dim sArg_Protokoll
Dim sArg_MaxFehler
Dim sArg_ProtFile
Dim sArg_Warten
Dim sArg_Fremd
'weitere Variablen
Dim nAnzahlArgumente
Dim arrArgumente
Dim objArgs
Dim strElement
Dim objFs
Dim sM3U_Lw
Dim sM3U_Lw_Pfad
Dim sDatei_M3U_List
Dim sZielPfad
Dim bFlach
Dim bRegister
Dim nMaxAnzahl
Dim bMP3_Protolollieren
Dim nMaxAnzahlFehlerCopy
Dim bProtokollFile
Dim nWarten
Dim bFremd
Dim sProtokoll
Dim bOk
'****** Dem Programm die angegenenen Argumente übergeben ************************************************
Set objArgs = WScript.Arguments
nAnzahlArgumente = objArgs.Count
If nAnzahlArgumente = 0 Then
'--- dem Script wurden keine Argumente übergeben darum werden die Konstanteneinstellungen übernommen
sDatei_M3U_List = DATEI_M3U_LIST
sZielPfad = ZIEL_PFAD
bFlach = FLACH
bRegister = False
nMaxAnzahl = MAX_ANZAHL
bMP3_Protolollieren = MP3_PROTOKOLLIEREN
nMaxAnzahlFehlerCopy = MAX_ANZAHL_FEHLER_COPY
bProtokollFile = MP3_PROTOKOLL_FILE
nWarten = WARTEN
bFremd = FREMD
Else
'--- dem Script wurden Argumente übergeben die Konstanteneinstellungen werden ignoriert.
'--- Zunächst die Default-Einstellungen
sDatei_M3U_List = ""
sZielPfad = ""
bFlach = False
bRegister = False
nMaxAnzahl = 0
bMP3_Protolollieren = False
nMaxAnzahlFehlerCopy = 30
bProtokollFile = False
nWarten = 0
bFremd=False
'--- Jetzt die Argumente übergeben
arrArgumente = Array(ARG_DATEI_M3U_LIST, ARG_ZIEL_PFAD, ARG_FLACH, ARG_REGISTER, ARG_MAX_ANZAHL, ARG_MAX_ANZAHL_FEHLER_COPY, ARG_MP3_PROTOKOLLIEREN, ARG_MP3_PROTOKOLL_FILE, ARG_WARTEN, ARG_FREMD)
For Each strElement In arrArgumente
If objArgs.Named.Exists(strElement) Then
Execute "sArg_" & strElement & "= objArgs.named(strElement)"
End If
Next
If Len(sArg_m3u) > 0 Then
sDatei_M3U_List = sArg_m3u
end if
If Len(sArg_Ziel) > 0 Then
sZielPfad = sArg_Ziel
end if
If Len(sArg_Flach) > 0 Then
if sArg_Flach = "1" then
bFlach = True
else
bFlach = False
end if
End If
If Len(sArg_Register) > 0 Then
if sArg_Register = "1" then
bRegister = True
else
bRegister = False
end if
End If
If Len(sArg_MaxAnzahl) > 0 Then
nMaxAnzahl = CLng(sArg_MaxAnzahl)
End If
If Len(sArg_Protokoll) > 0 Then
if sArg_Protokoll = "1" then
bMP3_Protolollieren = True
else
bMP3_Protolollieren = False
end if
End If
If Len(sArg_MaxFehler) > 0 Then
nMaxAnzahlFehlerCopy = CLng(sArg_MaxFehler)
End If
If Len(sArg_ProtFile) > 0 Then
if sArg_ProtFile = "1" then
bProtokollFile = True
else
bProtokollFile = False
end if
End If
If Len(sArg_Warten) > 0 Then
nWarten = CLng(sArg_Warten)
End If
If Len(sArg_Fremd) > 0 Then
if sArg_Fremd = "1" then
bFremd = True
else
bFremd = False
end if
End If
End If
' -------------------------- Aufruf des Hauptprogrammes ----------------------------------------------------
bOk=Copy_MP3_Aus_M3U_List(sDatei_M3U_List, sZielPfad, bFlach, bRegister, nMaxAnzahl, bMP3_Protolollieren, sProtokoll, nMaxAnzahlFehlerCopy, nWarten, bFremd)
if bOk then
if bProtokollFile Then
Set objFs = CreateObject("Scripting.FileSystemObject")
sM3U_Lw = objFS.GetDriveName(sDatei_M3U_List)
sM3U_Lw_Pfad = objFS.GetParentFolderName(sDatei_M3U_List)
bOk =TextdateiSchreiben( sM3U_Lw_Pfad & "\" & PROTOKOLL_DATEI , sProtokoll, True)
end if
if bFremd then
else
WScript.Echo "MP3 Dateien kopiert" & vbNewLine & vbNewLine & sProtokoll
end if
else
if bFremd then
else
WScript.Echo "---- Fehler beim kopieren der M3U-Liste ------" & vbNewLine & vbNewLine & sProtokoll
end if
end if
'-------------------------------------------------------------------------
'Funktionsname: Copy_MP3_Aus_M3U_List
'Beschreibung: Kopiert Dateien von Quelle nach Ziel ohne direktem Feedback über den
' Kopiervorgang beim Anwender
'
' Die erforderlichen Pfade werden automatisch erzeugt
'
'ÜbergabeVariablen: sDatei_M3U_List: M3U-L-Datei aus der kopiert werden soll
' z.B. D:\Install\Musik\Best Of\Pop\aa_Best of Pop_gemischt.m3u
' sZielPfad: Lw-Pfad wohin die Mp3-dateien hin kopiert werden sollen
' bFlach: True ==> alle MP3-Files erden in das gleiche Verzeichnis Kopiert
' False ==> die MP3-Files werden in Ihre Ursprungs-Verzeichnisse kopiert
' bRegister True ==> alle MP3-Files werden anhand des Dateinamens
' in ein Register Kopiert (A, B, C, D, ...)
' False ==> kein Register
' nMaxAnzahl: Anzahl der Maximal zu kopierenden Files, bei Angabe von 0 gibt es keine Grenze
' bMP3_Protolollieren: Nicht nur die Fehler sondern auch das kopieren der MP3-Files wird mitprotokolliert
' True ==> es wird protokolliert welche Mp3-Dateien kopiert wurden und welche nicht
' False ==> Mp3-Dateien kopieren wird nicht protokolliert.
' sProtokoll: Protokoll-String
' nMaxAnzahlFehlerCopy: nach nMaxAnzahlFehlerCopy hintereinander fehlerhaften Kopiervorgängen wird abgebrochen
' nWarten: Ist WARTEN > 0 wird der Task beim kopieren der MP3-Files für diese Zeiteinheit
' in Milli Sekunden abgegeben. Z.B. WARTEN = 100 dann bedeutet es das der Task
' für 100 Milli Sekunden abgegeben wird, bevor die nächste MP3-Datei kopiert wird.
' bFremd: True ==> Das Script kann von einem anderen Programm aufgerufen werden, darum sind die
' Bildschirmmeldungen unterdrückt und der Kopiervorgang wird in der Regestry eingetragen
' um die Möglichkeit zu geben mit einem anderen Programm für dessen Meldungen auf die Registry zuzugreifen.
' False ==> Kein Regestry-Eintrag und die Bildschirmmeldungen werden ausgegeben.
'
'Rückgabewert: TRUE ==> Kopiervorgang der MP3-Dateien in der Regel OK (auch wenn einzelne Dateien nicht kopiert werden konnten)
' FALSE ==> Kopiervorgang Fehlerhaft
'-------------------------------------------------------------------------
Function Copy_MP3_Aus_M3U_List(sDatei_M3U_List, ByVal sZielPfad, ByVal bFlach, ByVal bRegister, ByVal nMaxAnzahl, ByVal bMP3_Protolollieren, sProtokoll, ByVal nMaxAnzahlFehlerCopy, ByVal nWarten, ByVal bFremd)
'---- Konstanten für die Funktion ------------------------------------------------------------
'---- für Registrierungsdatenbank ------------------------------------------------------------
Const REG_HKLM = "HKLM" 'HKEY_LOCAL_MACHINE
Const REG_HKCU = "HKCU" 'HKEY_CURRENT_USER
Const REG_HKCR = "HKCR" 'HKEY_CLASSES_ROOT
Const REG_HAUPTSCHLUESSEL = "HKCU\Software\VBScript\CopyMP3ausM3U\"
Const REG_OK = "Ok"
Const REG_RUN = "Run"
Const REG_PROTOKOLL = "Protokoll"
Const REG_FEHLER = "Fehler"
'---- Weitere Konstanten ---------------------------------------------------------------------
Const PROTOKOLL_DATEI = "CopyMp3.log"
Const ZUM_LESEN = 1 'Öffnen der Datei zum Lesen
Dim bEgal
Dim objFs
Dim objAusgabe
Dim bRet
Dim nAnzahl
Dim nAnzFehlerCopy
Dim sNewM3UListe
Dim bOk
Dim bFirst
Dim sLeseZeile
Dim sLeseZeile_Dateierweiterung
Dim sLeseZeile_Lw
Dim sLeseZeile_Lw_Pfad
Dim sLeseZeile_Datei
Dim sRegister
Dim sQuellPfad
Dim sZielPfadGesamt
Dim sDateien
Dim sFehler
Dim sM3U_Lw
Dim sM3U_Lw_Pfad
Dim sM3U_Datei
Dim sM3U_Dateierweiterung
bRet = True
bFirst = True
nAnzFehlerCopy = 0
if bFremd Then
' Registryeintrag für Run gestartet = 1
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_RUN, 1, "" )
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_OK, 1, "" )
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, "", "")
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "", "")
End if
'--- M3U-Listen-Datei öffnen
Set objFs = CreateObject("Scripting.FileSystemObject")
sM3U_Dateierweiterung = objFS.GetExtensionName(sDatei_M3U_List)
sM3U_Lw = objFS.GetDriveName(sDatei_M3U_List)
sM3U_Lw_Pfad = objFS.GetParentFolderName(sDatei_M3U_List)
sM3U_Datei = objFS.GetFileName(sDatei_M3U_List)
if IstLaufwerkOk(objfs.GetDriveName(sZielPfad), sFehler) then
'Ziellaufwerk ist bereit
if LCase(sM3U_Dateierweiterung) = "m3u" then
' von der Dateierweiteung eine M3U-Liste
If objfs.FileExists(sDatei_M3U_List) Then
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objAusgabe = objFs.OpenTextFile(sDatei_M3U_List,ZUM_LESEN,True)
nAnzahl = 1
Do Until objAusgabe.AtEndOfStream
'---Zeile der M3U-Liste einlesen
if nWarten > 0 Then
'für nWarten in Milisekunden den Task abgeben
WScript.Sleep nWarten
End if
sLeseZeile = LCase(objAusgabe.ReadLine)
sLeseZeile_Dateierweiterung = objFS.GetExtensionName(sLeseZeile)
if sLeseZeile_Dateierweiterung = "mp3" then
'In diese Zeile ist eine MP3-Datei beschrieben
sLeseZeile_Lw = objFS.GetDriveName(sLeseZeile)
sLeseZeile_Lw_Pfad = objFS.GetParentFolderName(sLeseZeile)
sLeseZeile_Datei = objFS.GetFileName(sLeseZeile)
if sLeseZeile_Lw = "" then
if bRegister then
sRegister = HoleRegister(sLeseZeile_Datei) & "\"
else
sRegister = ""
end if
'kein Laufwerk angegeben ==> logischer Dateiangabe
sQuellPfad = sM3U_Lw_Pfad & "\" & sLeseZeile_Lw_Pfad & "\"
if bFlach then
'alle MP3-Dateien werden in das selbe Verzeichnis kopiert
sZielPfadGesamt = sZielPfad & "\" & sRegister
sNewM3UListe = sRegister & sLeseZeile_Datei
else
'die MP3-Files werden in Ihre Ursprungs-Verzeichnisse kopiert
sZielPfadGesamt = sZielPfad & "\" & sRegister & sLeseZeile_Lw_Pfad & "\"
sNewM3UListe = sRegister & sLeseZeile
end if
else
'Laufwerk ist angegeben ==> Fester Dateiangabe
if bRegister then
sRegister = HoleRegister(sLeseZeile_Datei) & "\"
else
sRegister = ""
end if
sQuellPfad= sLeseZeile_Lw_Pfad & "\"
sZielPfadGesamt = sZielPfad & sRegister & Mid(sLeseZeile_Lw_Pfad,3) & "\"
sNewM3UListe = sZielPfadGesamt & sRegister & sLeseZeile_Datei
end if
sDateien = sLeseZeile_Datei
bOk=CopyDateien_Einfach_ohne_Dialog(sQuellPfad, sDateien, sZielPfadGesamt, sFehler)
if bOk Then
' Datei wurde ohne Fehler kopiert
nAnzFehlerCopy = 0
if bFirst then
bOk =TextdateiSchreiben( sZielPfad & "\" & sM3U_Datei, sNewM3UListe, True)
bFirst = False
else
bOk =TextdateiSchreiben( sZielPfad & "\" & sM3U_Datei, sNewM3UListe, False)
end if
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, sDateien, "")
end if
if bMP3_Protolollieren then
sProtokoll = sProtokoll & "OK Copy " & sQuellPfad & sDateien & vbNewLine
end if
'--- wenn nMaxAnzahl > 0 können nur die Maximale Anzahl von MP3-Files kopiert werden
if nMaxAnzahl > 0 then
if nAnzahl >= nMaxAnzahl then
Exit Do
end if
nAnzahl = nAnzahl +1
end if
else
' fehler beim kopieren der Datei
nAnzFehlerCopy = nAnzFehlerCopy + 1
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, "-F- " & sDateien, "")
end if
if bMP3_Protolollieren then
sProtokoll = sProtokoll & "Fehler Copy " & sQuellPfad & sDateien & vbNewLine
end if
end if
end if
if nAnzFehlerCopy > nMaxAnzahlFehlerCopy then
sProtokoll = sProtokoll & "Fehler !!! Abbruch des Kopiervorgangs durch nAnzFehlerCopy > Max Anzahl Fehlercopy"
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "Abbruch des Kopiervorgangs durch nAnzFehlerCopy > Max Anzahl Fehlercopy", "")
end if
Exit Do
end if
Loop
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_PROTOKOLL, "", "")
end if
objAusgabe.close
else
bRet = False
sProtokoll = sProtokoll & "Fehler !!! M3U-Liste ist nicht Vorhanden" & vbNewLine
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "M3U-Liste ist nicht Vorhanden", "")
end if
end if
else
'keine M3U-Liste
sProtokoll = sProtokoll & "Fehler !!! keine M3U-Liste" & vbNewLine
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "keine M3U-Liste", "")
end if
bRet = False
end if
else
sProtokoll = sProtokoll & "Fehler !!! Ziellaufwerk ist nicht bereit" & vbNewLine
if bFremd Then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_FEHLER, "Ziellaufwerk ist nicht bereit", "")
end if
bRet = False
end if
if bFremd Then
' Registryeintrag für Run gestartet = 1
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_RUN, 0, "")
if bRet then
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_OK, 1, "")
else
bEgal =RegWriteKey(REG_HAUPTSCHLUESSEL & REG_OK, 0, "")
end If
End if
Copy_MP3_Aus_M3U_List = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: RegWriteKey
'Beschreibung: Schreibt einen Eintrag in die Regestry
'ÜbergabeVariablen: sReg_Schluessel: Enthält den zu beschreibenden Schlüssel
' sReg_Argument: Entält den übergebenen Wert des Schlüssels
' sRegTyp: der Argumettyp z:B.
' "", "REG_BINARY","REG_DWORD","REG_SZ", "REG_EXPAND_SZ"
'Rückgabewert: TRUE ==> Übergabe OK
' FALSE ==> Fehler beim Scheiben in die Regestry
'-------------------------------------------------------------------------
Function RegWriteKey(ByVal sReg_Schluessel, ByVal sReg_Argument, ByVal sRegTyp)
Dim objShell
dim bRet
On Error Resume Next
Set objShell = CreateObject("WScript.Shell")
if len(sRegTyp) > 0 then
objShell.RegWrite sReg_Schluessel, sReg_Argument, sRegTyp
else
objShell.RegWrite sReg_Schluessel, sReg_Argument
end if
If Err.Number = 0 Then
bRet = True
else
bRet = False
end if
On Error Goto 0
RegWriteKey = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: CopyDateien_Einfach_ohne_Dialog
'Beschreibung: Kopiert Dateien von Quelle nach Ziel ohne Feedback über den
' Kopiervorgang beim Anwender. Es wird nur die 1. Ebene kopiert
'
' Die erforderlichen Pfade werden automatisch erzeugt
'
'ÜbergabeVariablen: sQuellPfad: Quellpfad z.B. c:\Temp\1\
' sDateien: Dateien die kopiert werden sollen z.B. *.*
' sZielPfad: Zielpfad z.B. c:\Temp\3\
' sProtokoll: Im Fehlerfall werden hier die Fehler gespeichert
'Rückgabewert: TRUE ==> Kopiervorgang Ok
' FALSE ==> Kopiervorgang Fehlerhaft
'-------------------------------------------------------------------------
Function CopyDateien_Einfach_ohne_Dialog(ByVal sQuellPfad, ByVal sDateien, ByVal sZielPfad, sProtokoll)
Dim oFs
Dim bRet
Dim bOk
dim objfs
On Error Resume Next
bRet = True
bOk=ErzeugeOrdner(sZielPfad,sProtokoll)
if bOk then
Set objfs = CreateObject("Scripting.FileSystemObject")
If Not objfs.FileExists(sZielPfad & sDateien) Then
'File noch nicht vorhanden also kopieren
Set oFs = CreateObject("Scripting.FileSystemObject")
oFs.CopyFile sQuellPfad & sDateien, sZielPfad
end if
If Err.Number = 0 Then
bRet = True
else
bRet = False
sProtokoll = sProtokoll & Err.Description & vbNewLine
end if
else
bRet = False
sProtokoll = sProtokoll & "Ordner kann nicht angelegt werden" & vbNewLine
end if
On Error Goto 0
CopyDateien_Einfach_ohne_Dialog = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: ErzeugeOrdner
'Beschreibung: Erzeugt Ordner mit beliebig vielen Unterordnern
' Es wird dabei untersucht ob das Laufwerk bereit ist
'ÜbergabeVariablen: sOrdner: String mit Laufwerk und Ordner
' sProtokoll: Im Fehlerfall werden hier die Fehler gespeichert
'Rückgabewert: TRUE ==> Ordner wurden erzeugt
' FALSE ==> Es wurden keine Ordner angelegt.
'-------------------------------------------------------------------------
Function ErzeugeOrdner(ByVal sOrdner, sProtokoll)
Dim objfs
Dim arrfeld
Dim strOrdner
Dim x
Dim sLaufwerk
Dim bRet
On Error Resume Next
bRet = False
Set objfs = CreateObject("Scripting.FileSystemObject")
nFehlerNr = 0
If Len(sOrdner) > 0 Then
sLaufwerk=objfs.GetDriveName(sOrdner)
If IstLaufwerkOk(sLaufwerk,sProtokoll) Then
arrfeld = Split(sOrdner, "\")
strOrdner = arrfeld(0) & "\"
For x = 1 To UBound(arrfeld)
strOrdner = objfs.BuildPath(strOrdner, arrfeld(x))
If Err.Number = 0 Then
bRet = True
If Not objfs.FolderExists(strOrdner) Then
objfs.CreateFolder strOrdner
If Err.Number = 0 Then
bRet = True
Else
bRet = False
sProtokoll = sProtokoll & Err.Description & vbNewLine
End If
End If
Else
bRet = False
sProtokoll = sProtokoll & Err.Description & vbNewLine
End If
Next
End If
End If
On Error Goto 0
ErzeugeOrdner = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: IstLaufwerkOk
'Beschreibung: Untersucht ob das angegebene Laufwerk bereit is
'ÜbergabeVariablen: sLw: String mit Laufwerk
' sProtokoll: Im Fehlerfall werden hier die Fehler gespeichert
'Rückgabewert: TRUE ==> Laufwerk bereit
' FALSE ==> Laufwerk nicht bereit
'-------------------------------------------------------------------------
Function IstLaufwerkOk(ByVal sLw, sProtokoll)
Dim objfs
Dim bRet
Dim objLw
On Error Resume Next
bRet = False
If sLw ="" Then
bRet =False 'kein Laufwerk angegeben
sProtokoll = sProtokoll & "Es ist kein Laufwerk angegeben" & vbNewLine
Else
Set objfs = CreateObject("Scripting.FileSystemObject")
If objfs.DriveExists(sLw) Then
'Laufwerk existiert
Set objLw = objfs.GetDrive(sLw)
If objLw.isReady Then
bRet =True 'Laufwerk ist bereit
Else
bRet =False 'Laufwerk ist nicht bereit
sProtokoll = sProtokoll & "Laufwerk ist nicht bereit" & vbNewLine
End If
Else
bRet =False 'Laufwerk existiert nicht
sProtokoll = sProtokoll & "Laufwerk exestiert nicht" & vbNewLine
End If
End If
On Error Goto 0
IstLaufwerkOk = bRet
End Function
'-------------------------------------------------------------------------
'Funktionsname: TextdateiSchreiben
'Beschreibung: Schreibt einen mehrzeiligen Text in eine Textdatei
'ÜbergabeVariablen: sNameTextDatei : Name der Textdatei (mit Laufwerk und Pfad)
' sText : Text der in die Textdatei geschrieben wird
' bUeberschreiben: TRUE ==> Datei wird überschrieben
' FALSE ==> Neuer Text wird angehängt
'Rückgabewert: 0 ==> Schreiben Ok
' <> 0 ==> Fehler beim Schreiben
' FehlerCode: 0 kein Fehler
' 1 Keine Dateiname angegeben
' 2 Es wurde kein Text übergeben
' 3 Der Pfad zum Dateinamen konnte nicht erstellt werden
'-------------------------------------------------------------------------
Function TextdateiSchreiben(ByVal sNameTextDatei, ByVal sText, ByVal bUeberschreiben)
Dim nOk
Dim bOk
Dim fso
Dim sPfad
Dim objfs
Dim objAusgabe
Dim sProtokoll
On Error Resume Next
nOk = 0
If nOk = 0 Then
If sNameTextDatei = "" Then
nOk = 1
End If
End If
If nOk = 0 Then
If sText = "" Then
nOk = 2
End If
End If
'--- Falls noch nicht vorhanden die Ordner erstellen.
If nOk = 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
sPfad = fso.GetParentFolderName(sNameTextDatei) ' In Laufwerk-Pfad auftrennen
bOk=ErzeugeOrdner(sPfad,sProtokoll)
If Not bOk Then
nOk = 3
End If
End If
'--- Dateiinhalt schreiben
If nOk = 0 Then
Set objfs = CreateObject("Scripting.FileSystemObject")
If Err.Number = 0 Then
If bUeberschreiben Then
Set objAusgabe = objfs.OpenTextFile(sNameTextDatei,2,True)
If Err.Number <> 0 Then
nOk = 5
End If
Else
Set objAusgabe = objfs.OpenTextFile(sNameTextDatei,8,True)
If Err.Number <> 0 Then
nOk = 5
End If
End If
If nOk = 0 Then
objAusgabe.WriteLine sText
If Err.Number <> 0 Then
nOk = 6
End If
End If
objAusgabe.Close
Else
nOk = 4
End If
End If
On Error Goto 0
TextdateiSchreiben = nOk
End Function
'-------------------------------------------------------------------------
'Funktionsname: HoleRegister
'Beschreibung: Ermittelt aus dem Dateinamen den Register-Buchstaben
' der erste Buchstabe des Dateinamens wird dazu verwendt
' mit folgenden Regeln: A bis Z wird zu A bis Z
' Ä wird zu A, Ö wird zu O, Ü wird zu O
' 0, 1 .. 8, 9 werden zu _
' alle anderen Zeichen werden zu -
'ÜbergabeVariablen: sDateiName : Dateiname
'Rückgabewert: Registerwert _, -, A bis Z
'-------------------------------------------------------------------------
Function HoleRegister(ByVal sDateiName)
Dim sRet
Dim sErster
dim sDatei
If sDateiName = "" Then
sRet = " "
Else
sDatei = UCase(Trim(sDateiName))
If sDatei = "" Then
sRet = " "
Else
sErster = Left(sDatei,1)
Select Case sErster
Case "A","B","C","D","E","F","G","H","I","J","K","L","M"
sRet = sErster
Case "N","O","P","Q","R","S","T","U","V","W","X","Y","Z"
sRet = sErster
Case "Ä"
sRet = "A"
Case "Ö"
sRet = "O"
Case "Ü"
sRet = "U"
Case "0","1","2","3","4","5","6","7","8","9"
sRet = "_"
Case Else
sRet ="-"
End Select
End if
End If
HoleRegister = sRet
End Function
#########################################################################
>>> countdown-programmstart.hta <<<
<html>
<head>
<!--
'v6.1***************************************************
' File: countdown-programmstart.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'*******************************************************
-->
<title>Programmstart - Zeitpunkt</title>
<HTA:APPLICATION
ID="HtaID"
APPLICATIONNAME = "CountDown"
SCROLL = "no"
NAVIGABLE = "no"
MAXIMIZEBUTTON = "no"
MINIMIZEBUTTON = "no"
CAPTION = "yes"
SHOWINTASKBAR = "yes"
ICON = "http://dieseyer.de/images/boese32x32.ico"
>
<style type="text/css">
<!--
SYSMENU = "yes"
MINIMIZEBUTTON = "yes" => verhindert bei minimiertem HTA "in den Vordegrund"
background:#601010; bordeaux (weinrot) => negative Info, Achtung, Nein
background:#004030; dunkelgrün => positive Info, OK, Ja
background:#601010; dunkelblau => neutrale Info
-->
<!--
html, body { font-Size:12pt; color:#E0C000; font-family:Verdana; /* font-weight:bold; */
background:#601010;
}
a { font-size:100%; color:#FFFFFF; text-decoration:underline; }
a:active { color:red; }
a:link { color:#FFE000; }
a:visited { color:#E0C000; }
a:hover { color:red; }
a:active { color:#E0C000; }
input, select, textarea
{ color:#1d2160; font-weight:bold; }
-->
</style>
<SCRIPT language=VBScript>
Const ProgrName = "notepad"
Dim vStartZeit : vStartZeit = CDate( now() + CDate( "01:01:00" ) )
Dim vAnzeigeNeu
Dim TastTaste ' um [F5] für HTA neu starten abzufangen
Dim Tst, Txt, Anwendung, i
Dim MsgPop : MsgPop = "5"
'**************************************************************
Sub AnzeigeNeu()
'**************************************************************
' Aufruf durch: vAnzeigeNeu = window.setInterval("AnzeigeNeu()", 250, "VBScript")
' aus vStartZeit die Sekunden auf ":00" setzen
vStartZeit = FormatDateTime( vStartZeit, vbShortDate ) & " " & FormatDateTime( vStartZeit, vbShortTime )
vRestZeit = FormatDateTime( CDate( CDate( vStartZeit ) - now() ) , vbLongTime )
Tst = DateDiff( "s", now(), CDate( vStartZeit ) )
Tst = FormatNumber( Tst, 0, 0, 0, -2 ) ' FormatNumber(Ausdruck[, AnzDezimalstellen[, FührendeNull[, KlammernFürNegativeWerte[, ZiffernGruppieren]]]])
If Tst <= 1 Then : vStartZeit = "" : self.close : Exit Sub
Ttt = "<br>CountDown bis zum Start des Programms => <b>""" & ProgrName & """</b><br>"
Ttt = "<br>CountDown bis zum Programmstart von <br><br><b> => """ & ProgrName & """ <=</b><br>"
document.all.idErsteZeile.innerHTML = Ttt
Ttt = vRestZeit ' vRestZeit zur Anzeige anpassen
If InStr( "x" & vRestZeit, "x00:" ) > 0 Then Ttt = Replace( "x" & vRestZeit, "x00:", "" ) & " min"
top.document.title = Replace( Replace( "x" & vRestZeit, "x00:00:", "00:" ), "x", "" ) & " bis Programmstart"
If Tst > 175 Then ' für unterschiedliche Anzeigeformat
document.all.idStartZeit.innerHTML = "Für den Programmstart ist der <b>" & vStartZeit & "</b> gesetzt - das ist in " & vRestZeit & " h."
document.all.idStartRest.innerHTML = "Programmstart in " & Ttt & "<br>"
Else
document.all.idStartZeit.innerHTML = "Für den Programmstart ist der <b>" & vStartZeit & "</b> gesetzt - das ist in " & Tst & " s."
document.all.idStartRest.innerHTML = "Programmstart in " & Tst & " sec<br>"
'' top.document.title = Tst & " s bis Programmstart"
End If
' In der letzten Stunde vor Ablauf wird diese HTA in den Vordergrund geholt - zur Erinnerung
' ~~~~~~~~~~~~~~~~~~~~~
' 1h, 1/2h, 1/4h, 5min und 1min vor Ablauf
Ttt = "-OK"
Txt = Fix( DateDiff( "n", now(), CDate( vStartZeit ) ) )
If MsgPop = "5" AND Txt < 61 Then MsgPop = "4" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "4" AND Txt < 31 Then MsgPop = "3" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "3" AND Txt < 21 Then MsgPop = "2" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "2" AND Txt < 11 Then MsgPop = "1" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "1" AND Txt < 4 Then MsgPop = "0" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If DateDiff( "s", now(), CDate( vStartZeit ) ) < 30 Then Ttt = "OK"
i = i + 1 : If i < 20 Then Exit Sub
If not Ttt = "OK" Then Exit Sub
i = 0
window.clearInterval( vAnzeigeNeu ) ' damit die Aktualisierung der Anzeige nicht beim In-Den-Vordergrund-Bringen dazwischen funkt
' In dem VBS wird mit AppActivate das startende HTA in den Vordergrund geholt.
' Dieser Umweg ist notwendig, da folgende Aufrufe nicht das gewünschte Ergebnis brachten:
'' document.focus()
'' self.focus
'' window.focus
'' self.setActive - gibst nicht
Dim progr : progr = top.document.title
Dim Datei : Datei = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\temp-.vbs"
Dim FileOut : Set FileOut = CreateObject("Scripting.FileSystemObject").CreateTextFile( Datei , true)
FileOut.WriteLine "' " & now() & " )"
FileOut.WriteLine "Tst = CreateObject(""WScript.Shell"").AppActivate( ""00:"" )"
FileOut.WriteLine "WScript.Sleep 333"
FileOut.WriteLine "Tst = CreateObject(""WScript.Shell"").AppActivate( ""00:"" )"
FileOut.WriteLine "WScript.Sleep 333"
FileOut.WriteLine "CreateObject(""WScript.Shell"").SendKeys""{F5}"""
FileOut.WriteLine "Set fso = CreateObject(""Scripting.FileSystemObject"")"
FileOut.WriteLine "If fso.FileExists( WScript.ScriptFullName ) Then fso.DeleteFile( WScript.ScriptFullName )"
' FileOut.WriteLine "WScript.Sleep 333"
' FileOut.WriteLine "WScript.Sleep 1000"
' FileOut.WriteLine "MsgBox Tst & "" - E N D E - "", , WScript.ScriptName"
FileOut.Close
Set FileOut = nothing
window.setTimeout "ProgrRun('" & Datei & "')", 333 ' warten bis VBS 'richtig' geschrieben ist
End Sub ' AnzeigeNeu()
'**************************************************************
Sub ProgrRun( DateiX )
'**************************************************************
CreateObject("WScript.Shell").Run DateiX , , True
window.setTimeout "Window_OnLoad()", 333 ' warten bis window.clearInterval 'richtig' wirkt
End Sub ' ProgrRun( DateiX )
'**************************************************************
Sub window_onbeforeunload
'**************************************************************
' window.event.returnValue = "> > > > > Mit dem Schließen dieser Anwendung wird das Programm gestartet! < < < < <"
' sollte [F5] gedrückt worden sein (beendet das HTA und lädt es neu)
If TastTaste = 116 Then Call RegKeySchreiben( vStartZeit ) : Exit Sub
CreateObject("WScript.Shell").Run ProgrName
End Sub ' window_onbeforeunload
'**************************************************************
Sub RegKeySchreiben( Wert ) ' http://dieseyer.de/scr/wmi-regkeywrite.vbs
'**************************************************************
Dim KeyPath : KeyPath = "SOFTWARE\dieseyer.de\Enviroment"
Dim KeyKey : KeyKey = "EndeZeit"
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Const HKLM = &H80000002
' Inhalt schreiben
oReg.CreateKey HKLM,KeyPath
oReg.SetStringValue HKLM,KeyPath,KeyKey,Wert
End Sub ' RegKeySchreiben( Wert )
'**************************************************************
Function RegKeyLesen() ' http://dieseyer.de/scr/wmi-regkeywrite.vbs
'**************************************************************
Dim KeyPath : KeyPath = "SOFTWARE\dieseyer.de\Enviroment"
Dim KeyKey : KeyKey = "EndeZeit"
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Const HKLM = &H80000002
' Inhalt lesen
oReg.GetExpandedStringValue HKLM,KeyPath,KeyKey,KeyInh
RegKeyLesen = KeyInh
Call RegKeySchreiben( "" )
End Function ' RegKeyLesen
'**************************************************************
Sub Window_OnLoad
'**************************************************************
Dim Tst
' window.moveto Links, Oben
window.moveto 50, 50 ' Position
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 820, 600
Tst = ""
Tst = RegKeyLesen()
If not Tst = "" Then Call StartZeitTest( Tst ) ' alte vStartZeit aus Reg verwendbar?
Call RegKeySchreiben( "" )
Call AnzeigeNeu()
Call ZeitAuswahl()
vAnzeigeNeu = window.setInterval("AnzeigeNeu()", 222, "VBScript")
End Sub ' Window_OnLoad
'**************************************************************
Sub ZeitAuswahl()
'**************************************************************
TastEing = 13
Dim Txt
Txt = Txt & " <Span style=""font-size:12pt""> "
Txt = Txt & " <fieldset><Legend align=""Center""> Zeit bis Programmstart verkürzen: </legend> "
Txt = Txt & " </Span><Span style=""font-size:10pt""> "
Txt = Txt & " <br> <input Type=""text"" Name=""neueZeit"" Value="" "" > "
Txt = Txt & " <br><br> "
Txt = Txt & " <p align=""Left""> Erlaubte Eingaben: <br> "
Txt = Txt & " <b>3,5h</b> Programmstart in 3 Stunden und 30 Minuten <br> "
Txt = Txt & " <b>120min</b> Programmstart in 120 Minuten <br> "
Txt = Txt & " <b>2:15</b> Programmstart um 2 Uhr und 15 Minuten (oder 14:15) "
Txt = Txt & " <p> "
document.all.AnzeigeHTA.innerHTML = Txt
End Sub ' ZeitAuswahl()
'**************************************************************
Sub document_onKeyDown
'**************************************************************
TastTaste = window.event.keyCode
If TastTaste = 13 Then Call neuesEnde()
End Sub
'**************************************************************
Sub neuesEnde()
'**************************************************************
Call StartZeitTest( UCase( Document.All.neueZeit.Value ) )
End Sub ' neuesEnde()
'**************************************************************
Sub StartZeitTest( Tst )
'**************************************************************
Dim errTst
Dim X : X = "-"
' MsgBox Tst, , "256 :: "
On Error Resume Next
err.Clear : If InStr( Tst, ":" ) > 0 Then Tst = CDate( Tst ) : If err.Number = 0 Then X = "+"
err.Clear : If InStr( Tst, "M" ) > 0 Then Tst = DateAdd( "n", Replace( Tst, "M" , "" ) , now() ) : If err.Number = 0 Then X = "+"
err.Clear : If InStr( Tst, "MIN" ) > 0 Then Tst = DateAdd( "n", Replace( Tst, "MIN" , "" ) , now() ) : If err.Number = 0 Then X = "+"
err.Clear : If InStr( Tst, "H" ) > 0 Then Tst = DateAdd( "n", Replace( Tst, "H" , "" ) * 60 , now() ) : If err.Number = 0 Then X = "+"
If X = "-" Then MsgBox "Ungültige Eingabe!", 48, "267 :: " : Exit Sub
On Error GoTo 0
' MsgBox Tst, , "271 :: "
' If Tst < DateAdd( "d", -2, vStartZeit ) Then MsgBox Tst & vbCRLF & CDate( date() & " " & Tst ): Tst = CDate( date() & " " & Tst )
If Tst < DateAdd( "d", -2, vStartZeit ) Then Tst = CDate( date() & " " & Tst )
If Tst < now() Then Tst = DateAdd( "h", 12 , Tst )
If Tst < now() Then Tst = DateAdd( "h", 12 , Tst )
If Tst < now() Then Tst = DateAdd( "h", 12 , Tst )
' If DateDiff( "h", Tst, now() ) > 12 Then MsgBox Tst & vbCRLF & DateAdd( "h", Tst , -12 ) & vbCRLF & vStartZeit : Tst = DateAdd( "h", Tst , -12 )
If DateDiff( "h", Tst, now() ) > 12 Then Tst = DateAdd( "h", Tst , -12 )
' MsgBox Tst & vbCRLF & vStartZeit
If Tst > CDate( vStartZeit ) Then MsgBox vbTab & "Ungültige Eingabe!" & vbCRLF & vbCRLF & "Die Zeit bis zum Programmstart kann nur verkürzt werden!", 48, "284 :: ==> " & Tst : Call ZeitAuswahl() : Exit Sub
vStartZeit = Tst
Call AnzeigeNeu()
Call ZeitAuswahl()
End Sub ' StartZeitTest( Tst )
</SCRIPT>
</HEAD>
<BODY>
<form>
<center>
<span style="font-size:20pt;" ID=idErsteZeile> </span>
<br><br><span style="font-size:36pt;font-weight:bold;" ID=idStartRest></span><br><br>
<b><u> A C H T U N G</u> =></b> Mit dem Schließen dieses Fensters wird das Programm <u>sofort</u> gestartet!
<br><br>
<span ID=idStartZeit></span>
<br><br>
<table align="Center" border="0" cellspacing="20px" width="066%">
<tr >
<td align="Center" cellspacing="70%" >
<div ID=AnzeigeHTA >
</td>
</tr>
</table>
</form>
</BODY>
</html>
#########################################################################
>>> cpu-last-test.vbs <<<
'12345678x
' x
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' On Error Resume Next
Dim oArgs : set oArgs = Wscript.Arguments
Dim PauseZeit : PauseZeit = 23 ' Pause zw. den einzelnen Messungen
Dim TestAnzah : TestAnzah = 200
strComputer = "."
strComputer = "SRV01.BEIMIR.LOKAL"
Call Test2()
WScript.Quit
If oArgs.Count = 0 then strComputer = "."
strComputer = oArgs.item(i)
If not WMIpingOK( strComputer ) Then MsgBox "PCname """ & strComputer & " ist nicht erreichbar!", , "0024 :: ENDE - " & Wscript.ScriptName : WScript.Quit
i = 0
Do
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor")
i = i + 1
For Each objItem in colItems
' Wscript.Echo i & " Address Width: " & objItem.AddressWidth
' Wscript.Echo i & " Architecture: " & objItem.Architecture
' Wscript.Echo i & " Availability: " & objItem.Availability
' Wscript.Echo i & " CPU Status: " & objItem.CpuStatus
Tst = Tst & vbTab & objItem.LoadPercentage
' Wscript.Echo i & " Data Width: " & objItem.DataWidth
' Wscript.Echo i & " Description: " & objItem.Description
' Wscript.Echo i & " Device ID: " & objItem.DeviceID
' Wscript.Echo i & " Ext Clock: " & objItem.ExtClock
' Wscript.Echo i & " Family: " & objItem.Family
' Wscript.Echo i & " L2 Cache Size: " & objItem.L2CacheSize
' Wscript.Echo i & " L2 Cache Speed: " & objItem.L2CacheSpeed
' Wscript.Echo i & " Level: " & objItem.Level
' Wscript.Echo i & " Load Percentage: " & objItem.LoadPercentage
' Wscript.Echo i & " Manufacturer: " & objItem.Manufacturer
' Wscript.Echo i & " Maximum Clock Speed: " & objItem.MaxClockSpeed
' Wscript.Echo i & " Name: " & objItem.Name
' Wscript.Echo i & " PNP Device ID: " & objItem.PNPDeviceID
' Wscript.Echo i & " Processor Id: " & objItem.ProcessorId
' Wscript.Echo i & " Processor Type: " & objItem.ProcessorType
' Wscript.Echo i & " Revision: " & objItem.Revision
' Wscript.Echo i & " Role: " & objItem.Role
' Wscript.Echo i & " Socket Designation: " & objItem.SocketDesignation
' Wscript.Echo i & " Status Information: " & objItem.StatusInfo
' Wscript.Echo i & " Stepping: " & objItem.Stepping
' Wscript.Echo i & " Unique Id: " & objItem.UniqueId
' Wscript.Echo i & " Upgrade Method: " & objItem.UpgradeMethod
' Wscript.Echo i & " Version: " & objItem.Version
' Wscript.Echo i & " Voltage Caps: " & objItem.VoltageCaps
Next
If Len( i ) = 1 Then Tst = strComputer & vbTab & "00" & i & ":" & Tst & vbTab & Now()
If Len( i ) = 2 Then Tst = strComputer & vbTab & "0" & i & ":" & Tst & vbTab & Now()
If Len( i ) = 3 Then Tst = strComputer & vbTab & "" & i & ":" & Tst & vbTab & Now()
Wscript.Echo Tst : Tst = ""
' MsgBox WSCript.ScriptFullName
' WScrip.Sleep 1*1000
If not fso.FileExists( WSCript.ScriptFullName ) Then Exit Do
WScript.Sleep 1
Set objWMIService = nothing
Set colItems = nothing
Loop
MsgBox "ENDE"
'**************************************************************
Function WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
' Aufruf z.B.: If not WMIpingOK( ZielPC ) Then MsgBox ZielPC & " ist nicht erreichbar." : WScript.Quit
Dim objPing, objStatus
WMIpingOK = True
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & PCName & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
WScript.Echo("machine " & machine & " is not reachable")
WMIpingOK = False
End If
Next
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'**************************************************************
Function Test()
'**************************************************************
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
set objRefresher = CreateObject("WbemScripting.Swbemrefresher")
Set objProcessor = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfOS_Processor").objectSet
intThresholdViolations = 0
objRefresher.Refresh
Do
For each intProcessorUse in objProcessor
Tst = intProcessorUse.PercentProcessorTime
If not IsNull( Tst ) Then MsgBox Tst & " - " & intProcessorUse.Description
' If intProcessorUse.PercentProcessorTime > 90 Then
' intThresholdViolations = intThresholdViolations + 1
' If intThresholdViolations = 10 Then
' intThresholdViolations = 0
' Wscript.Echo "Processor usage threshold exceeded."
' End If
' Else
' intThresholdViolations = 0
' End If
Next
' Wscript.Sleep 6000
objRefresher.Refresh
Loop
End Function ' Test()
'**************************************************************
Function Test2()
'**************************************************************
Dim FileOut : Set FileOut = fso.OpenTextFile( Replace( WSCript.ScriptFullName, ".vbs", ".log" ), 8, true)
fileOut.WriteLine( "0103 :: " & now() & vbTab & "Skriptstart auf " & strComputer )
' WMI bereit stellen
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Dim objRefresher : Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Dim colItems : Set colItems = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfProc_Process").objectSet
Dim objItem
objRefresher.Refresh
' wscript.sleep( 3*1000 )
n = 1
Do
fileOut.WriteLine( n & ". Durchlauf folgt" & vbTab & Now() & " (" & Timer() & ")" )
Set CpuItems = GetObject("winmgmts:\\" & strComputer & "\root\cimv2").ExecQuery("Select * from Win32_Processor")
Tst = "" : i = 0
For Each objItem in CpuItems
i = i + 1
Tst = Tst & vbTab & objItem.LoadPercentage
Next
Set objWMIService = nothing
Set CpuItems = nothing
fileOut.WriteLine( Tst & vbTab & " <= ist %-Auslastung jeder der " & i & " CPUs" & vbTab & Now() & " (" & Timer() & ")" )
For Each objItem in colItems
' If InStr( LCase( objItem.Name ), LCase( Progr ) ) > 0 Then
If objItem.PercentProcessorTime > 0 Then
Txt = UCase( objItem.Name )
If Txt <> "_TOTAL" AND Txt <> "IDLE" Then
' If Txt <> "IDLE" Then
' Txt = Txt & "Handle Name: " & objItem.Name & vbTab
' Txt = Txt & "Handle Count: " & objItem.HandleCount & vbTab ' Eine Handleanzahl, die kontinuierlich zunimmt, ohne jemals abzunehmen, weist oft darauf hin, dass nicht der gesamte reservierte Speicher freigegeben wird.
' Txt = Txt & "Percent Processor Time: " & objItem.PercentProcessorTime & vbTab ' % CPU-Last
' Txt = Txt & "Working Set: " & objItem.WorkingSet & vbTab ' verw. RAM ?
' Txt = objItem.PercentProcessorTime & " - " & objItem.WorkingSet & " - " & objItem.HandleCount & " - " & objItem.Name
Txt = objItem.PercentProcessorTime & vbTab & Right( "00000000000000" & objItem.WorkingSet, 12 ) & vbTab & objItem.HandleCount & vbTab & objItem.Name
' fileOut.WriteLine( now() & vbTab & Txt ) : Txt = ""
fileOut.WriteLine( Txt )
End If
End If
Next
fileOut.WriteLine( n & ". Durchlauf erledigt" & vbTab & Now() & " (" & Timer() & ")" )
wscript.sleep( PauseZeit * 1000 ) : n = n + 1 : If n > TestAnzah Then Exit Do
objRefresher.Refresh
Loop
' 2 000031109120 367 w3wp
fileOut.WriteLine( "% " & vbTab & "[ Memory ]" & vbTab & "Handle" & vbTab & "Name" )
fileOut.WriteLine( "0136 :: " & now() & vbTab & "Skriptende auf " & strComputer & vbCRLF )
fileOut.Close
Set FileOut = Nothing ' Datei schließen
End Function ' Test2()
#########################################################################
>>> cr2crlf.vbs <<<
'v3.5********************************************************
' File: cr2crlf.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' wandelt in einer Datei jedes CR zu CRLF um (und löscht alle
' CRLFLF).
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird halt das Skript gelesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = i + 1
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
' Zeile(i) = i & vbTab & Zeile(i)
Zeile(i) = Replace( Zeile(i), vbCR, vbCRLF )
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF )
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF & "#X#" & i)
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF & "#X#" & i)
Zeile(i) = Replace( Zeile(i), vbCRLF & vbLF, vbCRLF & "#X#" & i)
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.DeleteFile( Datei )
#########################################################################
>>> crlf-entfernen.vbs <<<
'v5.1********************************************************
' File: crlf-entfernen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' entfernt alle CR, LF und CRLF aus einer Datei.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird halt das Skript gelesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' Datei komplett einlesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
Text = FileIn.ReadAll
FileIn.Close
Set FileIn = nothing
' Inhalt bearbeiten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox Text
Text = Replace( Text, vbCRLF , "" )
Text = Replace( Text, vbCRLF , "" )
Text = Replace( Text, vbCR , "" )
Text = Replace( Text, vbCR , "" )
Text = Replace( Text, vbLF , "" )
Text = Replace( Text, vbLF , "" )
MsgBox Text
' (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
FileOut.Write( Text )
FileOut.Close
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.DeleteFile( Datei )
#########################################################################
>>> datei-in-datum-sichern.vbs <<<
'*** v4.7 *** www.dieseyer.de ******************************
' File: datei-in-datum-sichern.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Skript überprüft, ob es eine bestimmte Datei gibt, kopiert
' diese in ein Sicherungsverzeichnis und benennt sie dabei
' um - der neue Dateiname ist der Kopierzeitpunkt.
' Die alte Datei wird gelöscht.
'***********************************************************
Option Explicit
Dim fso
Dim Dateiname, ZielVerz, Intervall, i, text
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dateiname = "c:\temp\wichtig.txt" ' Dateiname mit komplettem Pfad
ZielVerz = "d:\wichtige" '
ZielVerz = ZielVerz & "\"
Intervall = 10 ' Testintervall in Sekunden
i = 0
Do
if fso.FileExists( Dateiname ) Then
i = i +1
fso.CopyFile Dateiname, ZielVerz & DatumZeit & ".txt"
Fso.DeleteFile Dateiname
Text = MsgBox( Dateiname & vbCRLF & vbCRLF & "zum " & i &". mal gefunden - Skript beenden?", 4+256, WScript.ScriptName)
If Text = vbYes then Exit Do
End If
if fso.FileExists( fso.GetBaseName( WScript.ScriptName) & ".end" ) Then Exit Do
WScript.Sleep Intervall * 1000
Loop
MsgBox Dateiname & vbCRLF & vbCRLF & "zum " & i &". mal gefunden - Skript - Ende.", , WScript.ScriptName
if fso.FileExists( fso.GetBaseName( WScript.ScriptName) & ".end" ) Then fso.DeleteFile( fso.GetBaseName( WScript.ScriptName) & ".end" )
WScript.Quit
'*** v4.7 *** www.dieseyer.de ******************************
Function DatumZeit
'***********************************************************
' gibt ein Zeichenfolge zurück, die Datum / Zeit enthält
' und als Dateiname / Verzeichnisnae verwendet werden kann
Dim Zeit
Zeit = now()
' zweistellige Jahreszahl
DatumZeit = Right(Year(Zeit),2)
' zweistellige Monatszahl
If Len(Month(Zeit)) = 1 then DatumZeit = DatumZeit & "-0" & Month(Zeit)
If not Len(Month(Zeit)) = 1 then DatumZeit = DatumZeit & "-" & Month(Zeit)
' zweistellige Tageszahl
If Len(Day(Zeit)) = 1 then DatumZeit = DatumZeit & "-0" & Day(Zeit)
If not Len(Day(Zeit)) = 1 then DatumZeit = DatumZeit & "-" & Day(Zeit)
' zweistellige Stundezahl
If Len(Hour(Zeit)) = 1 then DatumZeit = DatumZeit & "_0" & Hour(Zeit)
If not Len(Hour(Zeit)) = 1 then DatumZeit = DatumZeit & "_" & Hour(Zeit)
' zweistellige Minutenzahl
If Len(Minute(Zeit)) = 1 then DatumZeit = DatumZeit & "'0" & Minute(Zeit)
If not Len(Minute(Zeit)) = 1 then DatumZeit = DatumZeit & "'" & Minute(Zeit)
' zweistellige Sekundenzahl
If Len(Second(Zeit)) = 1 then DatumZeit = DatumZeit & "'0" & Second(Zeit)
If not Len(Second(Zeit)) = 1 then DatumZeit = DatumZeit & "'" & Second(Zeit)
End Function ' DatumZeit
#########################################################################
>>> datei-verzeichnis-liste.vbs <<<
'v3.6*****************************************************
' File: Datei-Verzeichnis-Liste.vbs
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' Listet alle Dateien und danach alle Verzeichnisse
' in einem / dem aktuellen Verzeichnis
' Zieht man ein Verzeichnis oder eine Datei auf das Skript
' werden zu diesem Verzeichnis die Info's angezeigt.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, oArgs
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, Text, Pfad, DateiX, VerzX, Verz(), Datei()
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
If oArgs.Count > 0 Then ' gibt es Argumente?
Pfad = oArgs.item(0) ' erstes Argument
if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad )
' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist
Else ' es gibt keine Argumente!
Pfad = fso.GetFolder( "." ) ' Verzeichnis, in dem sich das Skript befindet
End If
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
' Dateiliste an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
ReDim Preserve Datei(i)
Datei(i) = DateiX.Name
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' Array an Text übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
If i > 0 then ' wenn es Datei(en) gibt
For i = 0 to UBound( Datei )
Text = Text & Pfad & "\" & Datei(i) & vbCRLF
Next
Else
Text = "keine Dateien vorhanden."
End If
MsgBox UCase(Pfad) & " enthält folgende " & i+1 & " Dateien:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
' Verzeichnisliste an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oSubFolder = oFolders.SubFolders
For Each VerzX In oSubFolder
ReDim Preserve Verz(i)
Verz(i) = VerzX.Name
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' Array an Text übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
If i > 0 then ' wenn es Verzeichnis(se) gibt
For i = 0 to UBound( Verz )
Text = Text & Pfad & "\" & Verz(i) & vbCRLF
Next
Else
Text = "keine Unterverzeichnisse vorhanden."
End If
MsgBox UCase(Pfad) & " enthält folgende " & i & " Verzeichnisse:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
#########################################################################
>>> dateialshtml.vbs <<<
'v3.7********************************************************
' File: DateiAlsHtml.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut, FileOutAll, oFolders, oFiles, oSubFolder
Dim Datei(), DateiX, VerzX, i, oArgs
Dim Txt, Text
Dim Quelle, Ziel, LaufW, Schreiben
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Quelle = oArgs.item(i)
Exit For ' ein Argument reicht
Next
if Quelle = "" then Quelle = WScript.ScriptName
' MsgBox Quelle, , WScript.ScriptName & " Anfang"
Quelle = fso.GetFile( Quelle ).Path
VBS1zuHTML (Quelle)
WSHShell.Popup Quelle & vbCRLF & vbCRLF & ". . . wurde in eine .HTML-Datei kopiert." , 10, WScript.ScriptName , 64
WScript.Quit
'************************************************************
Sub VBS1zuHTML (DateiX) ' Aufruf
'************************************************************
' .vbs-Datei bearbeiten und als .html speichern
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile( DateiX , 1 ) ' Datei zum Lesen öffnen
DateiX = fso.GetParentFolderName( DateiX ) & "\" & fso.GetBaseName( DateiX ) & ".html"
Set FileOut = FSO.OpenTextFile( DateiX, 2, true) ' Datei zum Schreiben öffnen; 2: immer neu anlegen
' Titelzeile für Skript in .html
FileOut.WriteLine "<body onLoad=""window.moveTo(screen.width-750),window.resizeTo(750,screen.height-50)"" >"
FileOut.WriteLine "<style type=""text/css""> <!-- body { background-color:#FFFFCC; line-height:45%; margin-left:20px; } --> </style> "
FileOut.WriteLine "<b><a href=""http://dieseyer.de"">http://dieseyer.de • all rights reserved • © " & VerNeuPunkt() & "</a></b>"
FileOut.WriteLine "<pre><br>"
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Txt = FileIn.Readline
FileOut.WriteLine( Txt & " <br>" )
Txt = Replace( Txt, ">", "&62" )
Txt = Replace( Txt, "<", "&60" )
FileOut.WriteLine( Txt & " <br>" )
Loop
' Fußzeile Skript in .html
FileOut.WriteLine "</pre>"
FileOut.WriteLine "<b><a href=""http://dieseyer.de"" target= ""_blank"">http://dieseyer.de • all rights reserved • © " & VerNeuPunkt() & "</a></b>"
FileOut.WriteLine "</body>"
FileIn.Close
FileOut.Close
Set FileIn = nothing
Set FileOut = nothing
WSHShell.run """C:\Programme\Internet Explorer\IEXPLORE.EXE"" " & DateiX
End Sub ' VBS1zuHTML (DateiX)
'************************************************************
Function VerNeuPunkt() ' Aufruf
'************************************************************
' dreistellige Jahreszahl & einstellige Jahreszahl + einstellige Monatszeichen
Dim Diff
Diff = 5
Diff = now() - Diff
VerNeuPunkt = Year( Diff ) & " v"
If Month( Diff ) < 10 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & "." & Month( Diff )
' MsgBox Month( Diff )
If Month( Diff ) = 10 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & ".A"
If Month( Diff ) = 11 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & ".B"
If Month( Diff ) = 12 then VerNeuPunkt = VerNeuPunkt & Right(Year( Diff ),1) & ".C"
End Function ' VerNeuPunkt ()
#########################################################################
>>> dateiauswahl-txtzeigen.hta <<<
<html>
<head>
<title>Load Computers Sample</title>
<HTA:APPLICATION
ID="objTestHTA"
APPLICATIONNAME="Load Computers Sample"
SCROLL="yes"
SINGLEINSTANCE="yes"
WINDOWSTATE="maximize"
>
</head>
<SCRIPT Language="VBScript">
Sub LoadComputers
Set objDialog = CreateObject("UserAccounts.CommonDialog")
objDialog.Filter = "Text Files|*.txt|All Files|*.*"
objDialog.FilterIndex = 1
objDialog.InitialDir = "C:\Scripts"
intResult = objDialog.ShowOpen
If intResult = 0 Then
Exit Sub
End If
For Each objOption in AvailableComputers.Options
objOption.RemoveNode
Next
ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile _
(objDialog.FileName, ForReading)
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
Set objOption = Document.createElement("OPTION")
objOption.Text = strLine
objOption.Value = strLine
AvailableComputers.Add(objOption)
Loop
objFile.Close
End Sub
</SCRIPT>
<body bgcolor="buttonface">
<input id=runbutton class="button" type="button" value="Load Computers"
name="run_button" onClick="LoadComputers"><p>
<select size="10" name="AvailableComputers" style="width:300" >
</select>
</body>
</html>
#########################################################################
>>> dateienaltdelete-2.vbs <<<
'v4.7********************************************************
' File: dateienaltdelete-2.vbs
'
' Autor: hos@ctmagazin.de
' http://www.heise.de/ct/faq/hotline/03/21/09.shtml
'
' Löscht alle Dateien, die seit einem bestimmten Datum
' nicht mehr geändert wurden
'
'************************************************************
' hier eigenen Bedürfnissen anpassen
Verzeichnis = "C:\Bilder" ' Hier wird gelöscht!
Aufheben = 31 ' Anzahl der Tage
' Ende der Anpassungen
Set fso = CreateObject("Scripting.FileSystemObject")
Set ordner = fso.GetFolder(Verzeichnis)
heute = Date()
DeleteInFolder(ordner)
Sub DeleteInFolder(ordner)
Set dateien = ordner.Files
' Alle Dateien in diesem Ordner abklappern
For Each datei In dateien
If datei.DateLastModified < (heute - Aufheben) Then
datei.Delete
End If
Next
Set untere = ordner.SubFolders
'Unterordner abklappern, DeleteInFolder rekursiv aufrufen
For Each unter In untere
DeleteInFolder(unter)
Next
End Sub
#########################################################################
>>> dateienaltdelete-3.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienaltdelete-3.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ursprungsskript:
' dateienalteliste.vbs
' mit der Prozedur AlteDateien( arrDateiLst, Alter, ZeitType )
'
' Erweiterungen:
' - die Prozedur "DateiListeLoeschen arrDateiLst"
' - Parameter um das Löschen zu aktivieren/deaktivieren (LoeschenAktiv = "YES")
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const Alter = 55
Const ZeitType = "d"
Const LoeschenAktiv = "-YES"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "039 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "040 :: LogDatei: " & LogDatei
LogEintrag "041 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "043 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "051 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
LogEintrag "055 :: arrDateiAlt = AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrDateiAlt = AlteDateien( arrDateiLst, Alter, ZeitType )
AlteDateien arrDateiLst, Alter, ZeitType
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateiListeLoeschen arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "075 :: " & WScript.ScriptName
LogEintrag "077 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateiListeLoeschen( arrDateiLst )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim i, m, n, z, Tst
i = 0 : m = 0 : n = 0 : z = 0
LogEintrag "089 :: Start der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
If LoeschenAktiv = "YES" Then LogEintrag "091 :: LÖSCHEN IST AKTIV - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
If LoeschenAktiv <> "YES" Then LogEintrag "092 :: LÖSCHEN IST DEAKTIVIERT - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
' Dateinamen des Arrays testen und Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
On Error Resume Next
Tst = " - "
If LoeschenAktiv = "YES" Then fso.DeleteFile arrDateiLst( i )
If LoeschenAktiv <> "YES" Then LogEintrag "102 :: Datei( " & i & " ) wird NICHT gelöscht: " & arrDateiLst( i )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
LogEintrag "108 :: Datei( " & i & " ) nicht löschbar: " & arrDateiLst( i ) & " " & Tst
z = z + 1
Else
If LoeschenAktiv = "YES" Then n = n + 1 : LogEintrag "111 :: Datei( " & i + 1 & " ) gelöscht: " & arrDateiLst( i )
End If
Else
If Len( arrDateiLst( i ) ) > 3 Then
LogEintrag "115 :: Datei( " & i & " ) fehlt (kann daher nicht gelöscht werden): " & arrDateiLst( i )
Else
m = m + 1
' LogEintrag "118 :: Datei( " & i & " ): " & arrDateiLst( i )
End If
End If
Next
LogEintrag "123 :: " & n & " von " & i & " Dateien gelöscht."
LogEintrag "124 :: " & z & "x ist ein Fehler beim Löschen einer Datei aufgetreten."
LogEintrag "125 :: " & m & " Arrayeinträge waren leer bzw. enthielten keinen gültigen Dateinamen."
LogEintrag "126 :: Ende der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
End Function ' DateiListeLoeschen( arrDateiLst )
'*** v7.C *** www.dieseyer.de ****************************
Function AlteDateien( arrDateiLst, Alter, ZeitType )
'*********************************************************
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst, Ttt, i
Dim ZeitBezug : ZeitBezug = "NACH"
LogEintrag "164 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' 'ZeitBezug' auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Left( Alter, 1 ) = "-" Then ZeitBezug = "VOR" : Alter = Mid( Alter, 2 )
If Left( Alter, 1 ) = "+" Then ZeitBezug = "NACH" : Alter = Mid( Alter, 2 )
If ZeitType = "VOR" Then ZeitBezug = "VOR"
If ZeitType = "NACH" Then ZeitBezug = "NACH"
LogEintrag "173 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' Prüfen, ob der Inhalt von 'Alter' verwendbar ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not IsDate( Alter ) Then Alter = CLng( Alter )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
' Alter enthält weder ein Datum noch eine Zahl; Alter ist ungültig!
WSHShell.Popup "Falscher Parameter für ""Alter"": " & vbCRLF & vbTab & "'" & Alter & "' führt zu" & vbCRLF & vbTab & Tst, 30, "183 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
LogEintrag "186 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
Tst = "-DATUM"
If InStr( Alter, ":" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "/" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "-" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "." ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If Tst <> "DATUM" Then Alter = CLng( Alter)
LogEintrag "193 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbTab & Tst
' Dateinamen des Arrays testen und ggf. im Array löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
Tst = fso.GetFile( arrDateiLst( i ) ).DateLastModified
Ttt = DateDiff( ZeitType, Tst, now() )
If IsDate( Alter ) Then
' arrDateiLst( i ) = Clng( Tst - Alter ) & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Tst - Alter < 0 Then arrDateiLst( i ) = "" ' & "N " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Tst - Alter > 0 Then arrDateiLst( i ) = "" ' & "V " & arrDateiLst( i )
Else
' arrDateiLst( i ) = Ttt & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Ttt < Alter Then arrDateiLst( i ) = "" ' & "n " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Ttt > Alter Then arrDateiLst( i ) = "" ' & "v " & arrDateiLst( i )
End If
'DateDiff(Intervall, Datum1, Datum2 [,ErsterWochentag[,ErsteWocheimJahr]] )
'Die Syntax der DateDiff-Funktion besteht aus folgenden
Next
End Function ' AlteDateien( arrDateiLst, Alter, ZeitType )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "263 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "264 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "282 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "291 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienaltdelete.vbs <<<
'v3.7*****************************************************
' File: DateienAltDelete.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Löscht alle Dateien, die seit einem bestimmten Datum
' nicht mehr geändert wurden
'*********************************************************
Option Explicit
Dim Pfad, Alter
Pfad = "d:\setup"
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet, Skript wird also auch gelöscht
Pfad = "c:\temp"
Alter = 365 ' Dateien, die seit xxx Tagen nicht geändert wurden
MsgBox AltesLoeschen (Pfad, Alter ) 'Function Aufruf und Ergebnisanzeige
AltesLoeschen "c:\temp", 100 'Function Aufruf OHNE Ergebnisanzeige
' ~~~~~~
WScript.Quit
'*********************************************************
Function AltesLoeschen (Pfad, Alter) ' Anfang
'*********************************************************
Dim fso, oFiles, i, Txt
Alter = FormatDateTime( now() - Alter ,2)
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!", , WScript.ScriptName
Exit Function
End If
AltesLoeschen = "In " & UCase( Pfad ) & " wurden vor dem " & Alter & " geändert Dateien gelöscht." & vbCRLF & vbCRLF
Set oFiles = fso.GetFolder( Pfad ).Files
For Each i In oFiles
if DateDiff("d" , i.DateLastModified, Alter) > 0 then ' vor dem Alter geänderte Dateien
Txt = i.path ' nach dem Löschen von i.Path ist auch i.Path gelöscht
AltesLoeschen = AltesLoeschen & i.Name & " " & vbTab & FormatDateTime( i.DateLastModified ,2)
On Error Resume Next
fso.DeleteFile i.path, True
On Error GoTo 0
If not fso.FileExists( Txt ) Then
AltesLoeschen = AltesLoeschen & vbCRLF
Else
AltesLoeschen = AltesLoeschen & " nicht gelöscht." & vbCRLF
End if
End If
Next
Set oFiles = nothing
Set fso = nothing
End Function ' AltesLoeschen
#########################################################################
>>> dateienaltdeletetyp-2.vbs <<<
'*** v10.8 *** www.dieseyer.de ******************************
'
' Datei: DateienAltDeleteTyp.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Löscht alle Dateien mit einer bestimmten Erweiterung, die
' seit einem bestimmten Datum nicht mehr geändert wurden.
' (Vergl. AcronisAlteTibEntfernen.vbs)
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Pfad, Alter, DateiTyp
DateiTyp = "rex"
DateiTyp = "cmd"
DateiTyp = "bak"
DateiTyp = "vbs"
Pfad = "d:\setup"
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet, Skript wird also auch gelöscht
Pfad = "c:\temp"
Alter = 365*7 ' Dateien, die seit xxx Tagen nicht geändert wurden
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call Trace32Log( " ", 0 ) ' erstellt neue LogDatei
Call Trace32Log( " ", 1 ) ' fügt Leerzeile in LogDatei ein
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup vbTab & "= = = S T A R T = = =", 2, "042 :: " & WScript.ScriptName, vbInformation
Trace32Log "043 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "044 :: LogDatei: " & LogDatei, 1
Trace32Log "045 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "046 :: Angemeldeter User: " & WSHNet.UserName, 1
AlteDateienErweiterung Pfad, Alter, DateiTyp
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.Popup vbTab & "= = = E N D E = = =", 2, "051 :: " & WScript.ScriptName, vbInformation
Trace32Log "052 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v10.8 *** www.dieseyer.de *****************************
Function AlteDateienErweiterung( Verz, Alter, DateiErw )
'***********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oFiles, Datei, Txt, errTst, i, n
DateiErw = UCase( DateiErw )
i = 0 : n = 0
Trace32Log "067 :: Alte Dateien sollen gelöscht werden - Verzeichnis: " & Verz, 1
Trace32Log "068 :: Alte Dateien sollen gelöscht werden - Dateierweiterung (Extension): " & DateiErw, 1
Trace32Log "069 :: Alte Dateien sollen gelöscht werden - min. Alter der zu löschenden Dateien: " & Alter, 1
Trace32Log "070 :: Alte Dateien sollen gelöscht werden - Änderungsdatum der Dateien vor: " & FormatDateTime( now() - Alter, 2), 1
if not fso.FolderExists( Verz ) then
WSHShell.Popup vbTab & "Verzeichnis existiert nicht:" & vbCRLF & vbCRLF & Verz, 5, "073 :: " & WScript.ScriptName, 4096 + vbCritical
Trace32Log "074 :: Verzeichnis existiert nicht: " & Txt, 3
Exit Function
End If
Trace32Log "078 :: ", 1
Set oFiles = fso.GetFolder( Verz ).Files
For Each Datei In oFiles
' Trace32Log "083 :: Datei wird geprüft: " & Datei.Path, 1
' Trace32Log "084 :: Letzte Dateiänderung: " & Datei.DateLastModified, 1
' Trace32Log "085 :: min. ALter: " & FormatDateTime( now() - Alter, 2) & " - " & Alter & "d", 1
' Trace32Log "086 :: ALtersunterschied zu heute: " & DateDiff( "d" , Datei.DateLastModified, Date() ) & "d", 1
' Trace32Log "087 :: Daeierweiterung: " & UCase( fso.GetExtensionName( Datei.Path ) ), 1
If not UCase( fso.GetExtensionName( Datei.Name) ) = DateiErw Then
Trace32Log "090 :: Daeierweiterung stimmt nicht: " & UCase( fso.GetExtensionName( Datei.Path ) ), 2
Else
' Trace32Log "092 :: " & DateDiff( "d" , Datei.DateLastModified, Date() ) & " > " & Alter , 1
If DateDiff( "d" , Datei.DateLastModified, Date() ) > Alter Then ' vor dem Alter geänderte Dateien
Txt = Datei.path ' nach dem Löschen von Datei.Path ist, fehlt Datei.Path
' Trace32Log "097 :: Datei soll gelöscht werden: " & Txt, 1
On Error Resume Next
fso.DeleteFile Txt, True
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
if Len( errTst ) < 5 Then
Trace32Log "104 :: Gelöscht: " & Txt, 1
i = i + 1
Else
Trace32Log "107 :: Nicht löschbar: " & Txt & " - " & errTst, 3
n = n + 1
End if
End if
End If
Next
Set oFiles = nothing
Set fso = nothing
Trace32Log "118 :: ", 1
Trace32Log "119 :: " & i & " Dateien sind gelöscht.", 1
Trace32Log "120 :: " & n & " Dateien wurden nicht gelöscht (wegen fehler).", 1
End Function ' AlteDateienErweiterung( Verz, Alter, DateiErw )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "209 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "210 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> dateienaltdeletetyp.vbs <<<
'*** v4.6 *** www.dieseyer.de *******************************
'
' Datei: DateienAltDeleteTyp.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Löscht alle Dateien mit einer bestimmten Erweiterung, die
' seit einem bestimmten Datum nicht mehr geändert wurden
'
'************************************************************
Option Explicit
Dim Pfad, Alter, DateiTyp
DateiTyp = "rex"
DateiTyp = "cmd"
DateiTyp = UCase(DateiTyp)
Pfad = "d:\setup"
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet, Skript wird also auch gelöscht
Pfad = "c:\temp"
Alter = 365 ' Dateien, die seit xxx Tagen nicht geändert wurden
MsgBox AltesLoeschen (Pfad, Alter ) 'Function Aufruf und Ergebnisanzeige
AltesLoeschen "c:\temp", 100 'Function Aufruf OHNE Ergebnisanzeige
' ~~~~~~
WScript.Quit
'*** v4.6 *** www.dieseyer.de *******************************
Function AltesLoeschen (Pfad, Alter) ' Anfang
'************************************************************
Dim fso, oFiles, i, Txt
Alter = FormatDateTime( now() - Alter ,2)
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!", , WScript.ScriptName
Exit Function
End If
AltesLoeschen = "In " & UCase( Pfad ) & " wurden vor dem " & Alter & " geändert Dateien gelöscht." & vbCRLF & vbCRLF
Set oFiles = fso.GetFolder( Pfad ).Files
For Each i In oFiles
if DateDiff("d" , i.DateLastModified, Alter) > 0 then ' vor dem Alter geänderte Dateien
Txt = i.path ' nach dem Löschen von i.Path ist auch i.Path gelöscht
AltesLoeschen = AltesLoeschen & i.Name & " " & vbTab & FormatDateTime( i.DateLastModified ,2)
On Error Resume Next
if UCase( fso.GetExtensionName(i.Name) ) = DateiTyp then
fso.DeleteFile i.path, True
End if
On Error GoTo 0
If not fso.FileExists( Txt ) Then
AltesLoeschen = AltesLoeschen & vbCRLF
Else
AltesLoeschen = AltesLoeschen & " nicht gelöscht." & vbCRLF
End if
End If
Next
Set oFiles = nothing
Set fso = nothing
End Function ' AltesLoeschen (Pfad, Alter) ' Ende
#########################################################################
>>> dateienalteliste.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienalteliste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const Alter = 955
Const ZeitType = "d"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "056 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "057 :: LogDatei: " & LogDatei
LogEintrag "058 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "060 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "068 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
LogEintrag "072 :: arrDateiAlt = AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrDateiAlt = AlteDateien( arrDateiLst, Alter, ZeitType )
AlteDateien arrDateiLst, Alter, ZeitType
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "085 :: " & WScript.ScriptName
LogEintrag "087 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function AlteDateien( arrDateiLst, Alter, ZeitType )
'*********************************************************
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst, Ttt, i
Dim ZeitBezug : ZeitBezug = "NACH"
LogEintrag "126 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbCRLF
' 'ZeitBezug' auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Left( Alter, 1 ) = "-" Then ZeitBezug = "VOR" : Alter = Mid( Alter, 2 )
If Left( Alter, 1 ) = "+" Then ZeitBezug = "NACH" : Alter = Mid( Alter, 2 )
If ZeitType = "VOR" Then ZeitBezug = "VOR"
If ZeitType = "NACH" Then ZeitBezug = "NACH"
LogEintrag "135 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbCRLF
' Prüfen, ob der Inhalt von 'Alter' verwendbar ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not IsDate( Alter ) Then Alter = CLng( Alter )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
' Alter enthält weder ein Datum noch eine Zahl; Alter ist ungültig!
WSHShell.Popup "Falscher Parameter für ""Alter"": " & vbCRLF & vbTab & "'" & Alter & "' führt zu" & vbCRLF & vbTab & Tst, 30, "145 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
LogEintrag "148 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbCRLF
Tst = "-DATUM"
If InStr( Alter, ":" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "/" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "-" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "." ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If Tst <> "DATUM" Then Alter = CLng( Alter)
LogEintrag "155 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & vbTab & Tst & vbCRLF
' Dateinamen des Arrays testen und ggf. im Array löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
Tst = fso.GetFile( arrDateiLst( i ) ).DateLastModified
Ttt = DateDiff( ZeitType, Tst, now() )
If IsDate( Alter ) Then
' arrDateiLst( i ) = Clng( Tst - Alter ) & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Tst - Alter < 0 Then arrDateiLst( i ) = "" ' & "N " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Tst - Alter > 0 Then arrDateiLst( i ) = "" ' & "V " & arrDateiLst( i )
Else
' arrDateiLst( i ) = Ttt & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Ttt < Alter Then arrDateiLst( i ) = "" ' & "n " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Ttt > Alter Then arrDateiLst( i ) = "" ' & "v " & arrDateiLst( i )
End If
'DateDiff(Intervall, Datum1, Datum2 [,ErsterWochentag[,ErsteWocheimJahr]] )
'Die Syntax der DateDiff-Funktion besteht aus folgenden
Next
End Function ' AlteDateien( arrDateiLst, Alter, ZeitType )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "225 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "226 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "244 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "253 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienaltverschieben.vbs <<<
'*** v7.8 *** www.dieseyer.de ****************************
'
' Datei: dateienaltverschieben.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Verschiebt alle Dateien, die seit einem bestimmten Datum
' nicht mehr geändert wurden. Gibt es den ZielDateiNamen
' bereits, wird dieser mit einer dreistelligen Zahl fort-
' laufend hoch gezählt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile Tst, ZDatei
' fso.CopyFile Tst, ZDatei
'
'*********************************************************
Option Explicit
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim QuellPfad, ZielPfad, Alter
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
QuellPfad = "H:\\scr\backup"
QuellPfad = "\\dieseyer.pc.netz\d$\temp.zw"
QuellPfad = "SRV01.BEIMIR.LOKAL\d$\1test"
ZielPfad = "D:\temp.zw\zw"
Alter = 365 ' Dateien, die seit xxx Tagen nicht geändert wurden
LogEintrag vbCRLF
LogEintrag "027 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "028 :: LogDatei: " & LogDatei
' MsgBox AlteVerschieben (QuellPfad, ZielPfad, Alter ) ' Function Aufruf und Ergebnisanzeige
AlteVerschieben QuellPfad, ZielPfad, Alter ' Function Aufruf OHNE Ergebnisanzeige
LogEintrag "033 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
CreateObject("Wscript.Shell").Run LogDatei ' LogDatei anzeigen
WScript.Quit
'*********************************************************
Function AlteVerschieben (QPfad, ZPfad, Tage) ' Anfang
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
LogEintrag "044 :: Start der Function-Prozedur 'Function AlteVerschieben (QPfad, ZPfad, Tage)'"
LogEintrag "045 :: QPfad: " & QPfad
LogEintrag "046 :: ZPfad: " & ZPfad
LogEintrag "047 :: Dateien, die älter als " & Tage & " Tage sind (vor dem " & FormatDateTime( now() - Tage ,2) & " erstellt), sollen verschoben werden . . ."
Dim oFiles, n, i, Txt, Tst, ZDatei, File
If not InStrRev( ZPfad, "\" ) = Len( ZPfad ) Then ZPfad = ZPfad & "\" ' evtl. fehlendes \ am Ende entfernen
If not fso.FolderExists( QPfad ) Then
AlteVerschieben = "Das Quellverzeichnis " & UCase( QPfad ) & " existiert nicht!"
MsgBox AlteVerschieben, , "055 :: " & WScript.ScriptName
LogEintrag "056 :: " & AlteVerschieben
Exit Function
End If
If not fso.FolderExists( ZPfad ) Then
AlteVerschieben = "Das Zielverzeichnis " & UCase( ZPfad ) & " existiert nicht!"
MsgBox AlteVerschieben, , "062 :: " & WScript.ScriptName
LogEintrag "063 :: " & AlteVerschieben
Exit Function
End If
Set oFiles = fso.GetFolder( QPfad ).Files
For Each File In oFiles
Txt = File.DateLastModified
If DateDiff("d" , File.DateLastModified, FormatDateTime( now() - Tage ,2) ) > 0 Then ' Datei alt genug?
i = i + 1
n = 0 : Tst = ""
ZDatei = File
ZDatei = ZPfad & fso.GetBaseName( File) & Tst & "." & fso.GetExtensionName( File )
Do ' Schleife durchlaufen, bis ein 'freier' (Ziel-) Dateiname gefunden ist
If not fso.FileExists( ZDatei ) Then Exit Do
n = n + 1 : Tst = n
If Len( Tst ) < 3 Then Tst = "0" & Tst
If Len( Tst ) < 3 Then Tst = "0" & Tst
If Len( Tst ) < 3 Then Tst = "0" & Tst ' n mit führenden Nullen auffüllen
Tst = "-" & Tst
ZDatei = ZPfad & fso.GetBaseName( File) & Tst & "." & fso.GetExtensionName( File )
' MsgBox "File" & vbTab & "=>" & File & "<=" & vbCRLF & "ZDatei" & vbTab & "=>" & ZDatei & "<=", , "085 :: " & WScript.ScriptName
Loop
Tst = File
On Error Resume Next
' fso.MoveFile Tst, ZDatei
fso.CopyFile Tst, ZDatei
On Error GoTo 0
If not fso.FileExists( ZDatei ) Then
AlteVerschieben = AlteVerschieben & i & vbTab & Tst & vbTab & " nicht verschiebbar." & vbCRLF
LogEintrag "096 :: Datei vom " & Txt & " nicht verschiebbar: " & Tst
Else
AlteVerschieben = AlteVerschieben & i & vbTab & ZDatei & vbTab & " erstellt - Quelle gelöscht." & vbCRLF
LogEintrag "099 :: Datei vom " & Txt & " verschoben nach: " & ZDatei & " - QuellDatei: " & Tst
End if
Else
LogEintrag "103 :: --- Datei vom " & File.DateLastModified & " nicht alt genung zum verschieben: " & File
End If
Next
Set oFiles = nothing
Set fso = nothing
LogEintrag "110 :: " & i & " Dateien, die älter als " & Tage & " Tage sind (vor dem " & FormatDateTime( now() - Tage ,2) & " erstellt), wurden verschoben."
End Function ' AlteVerschieben (QPfad, ZPfad, Tage)
'*********************************************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienlisteholen.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienlisteholen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "035 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "036 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "038 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst, Tst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "046 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
Tst = Replace( WScript.ScriptFullName, WScript.Scriptname, "" )
' Tst enthält jetzt das aktuelle Verzeichnis
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( Tst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "058 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "066 :: " & WScript.ScriptName
LogEintrag "068 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "119 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "120 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "138 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "147 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienvergleich-1.vbs <<<
'*** v10.2 *** www.dieseyer.de *****************************
'
' Datei: dateienvergleich-1.vbs
' Autor: W. Schmelz
' Auf: www.dieseyer.de
'
' Vergleich von zwei im Explorer markierter Dateien.
' Diese sind auch zusammen per Drag & Drop aufsetzbar.
' Die Unterschiede beider Dateien und Einschübe werden
' zeilenweise samt Nummerierung dieser Zeilen in einer
' Datei Datei-Vgl.txt im Programm-Ordner aufgelistet.
' Anfangs werden beide Dateien nummeriert angegeben.
' Die Leerstellen zum Einrücken (am Zeilenanfang) werden
' nicht beachtet. Die "Fc.exe" (FileCompare) von
' MS versagte an mehreren Beispielen und meldete Fehler -
' so hat sich die (Neu-) Programmierung immerhin gelohnt!
'
'***********************************************************
' CopyRight W. Schmelz, 10.02.2010 (Stammt aus 9/2007)
'Objekte u.a. für Arbeit des Programmes bereit stellen:
'******************************************************
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set IE=CreateObject("InternetExplorer.Application")
Set Arg=Wscript.Arguments
Titel=" Zwei Dateien vergleichen !"
UV=VbCR&VbCR
'Dim für Weitergabe zwischen Programm und Sub-Programmen:
'********************************************************
Dim Stelle, Neu1, Neu2, i, Plus1, Plus2, Ende1, Ende2, Ende
Dim Zeile1(), Zeile2(), Datei, Datei1, Datei2, Ident, Leer
Dim Nicht, Ort, Schrb, Edg1, Edg2, Dazu, Lang, Voll, Stern
Dim Verschd, Zeilen1(), Zeilen2()
'Prüfen, ob zwei Dateien zum Vergleich aufgesetzt wurden:
'********************************************************
If Arg.Count<>"2" then
Ask=MsgBox (UV&"Sollen jetzt zwei im Explorer zu bestimmen-"&_
UV&"de Dateien verglichen werden ? Die Dateien"&UV&_
"werden zeilenweise auf deren Unterschiede"&UV&_
"überprüft und während dessen getestet, ob "&_
UV&"in diese beiden Dateien Einschübe gemacht"&UV&_
"wurden ! Soll der Explorer geöffnet werden ?"&UV&_
"Man kann aber auch die 2 Dateien aufsetzen?"&UV, _
VbOkCancel+VbDefaultButton1+VbInformation+VbSystemModal,Titel)
If Ask="2" then WScript.Quit
else
'Evtl. aufgesetzte Dateien erkennen:
'***********************************
Datei1=Arg.Item(0)
Datei2=Arg.Item(1)
Text=" "&Arg.Item(0)&VbCR&" "&Arg.Item(1)
Ask=MsgBox(UV&"Folgende Dateien werden jetzt verglichen:"&_
" "&UV&Text&UV, _
VbOkCancel+VbDefaultButton1+VbInformation+VbSystemModal,Titel)
If Ask="2" then WScript.Quit
End If
'Falls nicht beide zu vergleichenden Dateien aufgesetzt wurden,
'statt dessen Auswahl der beiden Dateien im Explorer vornehmen:
'**************************************************************
If Arg.Count<>"2" then
IE.Navigate("About:Blank")
IE.Document.Write "<HTML><BODY><INPUT ID=""Files""Type=""File"">"
IE.Height="0" 'Muss sein, damit IE verborgen bleibt !!!
IE.Width="0"
IE.Visible=True
With IE.Document.All.Files
'Explorer-Fenster muss unbedingt sofort nach vorne kommen:
'*********************************************************
Befehl="about:blank - Microsoft Internet Explorer"
If Wss.AppActivate (Befehl) then Wss.AppActivate (Befehl)
'"Datei1" im Explorer auswählen:
'*******************************
.Click
Datei1= .Value
'Bei Abbruch der Auswahl:
'************************
If Datei1="" then
IE.Quit
Set IE=Nothing
WScript.Quit
End If
WScript.Sleep 500 '1/2 Sek. Pause zum Übergang
'"Datei2" im Explorer auswählen:
'*******************************
.Click
Datei2= .Value
IE.Quit
Set IE=Nothing
'Falls Dateien gleich oder Datei2="" sind:
'*****************************************
If Datei2="" then WScript.Quit
If Datei1=Datei2 then
MsgBox UV&" Abbruch, da die Datei1 = Datei2 !"&_
" "&UV,VbInformation+VbSystemModal,Titel
WScript.Quit
End If
End With
End If
'Prüfen, ob beide Dateien geeignet sind:
'***************************************
Edg1=LCase(Right(Datei1,3))
Edg2=LCase(Right(Datei2,3))
If not (Edg1="txt" or Edg1="vbs" or Edg1="hta" or _
Edg1="bat" or Edg1="sys" or Edg1="ini" or _
Edg1="log" or Edg1="cfg" or Edg1="old") or _
not (Edg2="txt" or Edg2="vbs" or Edg2="hta" or _
Edg2="bat" or Edg2="sys" or Edg2="ini" or _
Edg2="log" or Edg2="cfg" or Edg2="old") _
then MsgBox UV&"Diese Dateien sind leider ungeeignet! "&_
" "&UV,VbCritical+VbSystemModal,Titel:WScript.Quit
'Datei mit weniger Zeilen "Datei1" nennen:
'*****************************************
Set File1=Fso.OpenTextFile(Datei1,1,true)
i=1
Do until File1.AtEndOfStream
File1.ReadLine
i=i+1
Loop
Ende1=i-1
File1.Close
Set File1=Nothing
Set File2=Fso.OpenTextFile(Datei2,1,true)
i=1
Do until File2.AtEndOfStream
File2.ReadLine
i=i+1
Loop
Ende2=i-1
File2.Close
Set File2=Nothing
If Ende1>Ende2 then
DateiX=Datei1
Datei1=Datei2
Datei2=DateiX
else
'Nrn. bleiben so
End If
'"Datei1" zeilenweise auslesen:
'******************************
Set File1=Fso.OpenTextFile(Datei1,1,true)
i=1
Do until File1.AtEndOfStream
ReDim Preserve Zeile1(i)
Zeile1(i)=File1.ReadLine
i=i+1
Loop
Ende1=i-1
File1.Close
Set File1=Nothing
'"Datei2" zeilenweise auslesen:
'******************************
Set File2=Fso.OpenTextFile(Datei2,1,true)
i=1
Do until File2.AtEndOfStream
ReDim Preserve Zeile2(i)
Zeile2(i)=File2.ReadLine
i=i+1
Loop
Ende2=i-1
File2.Close
Set File2=Nothing
'Dateien gleich, wenn gleich lang und Zeilen identisch:
'******************************************************
If Ende1=Ende2 then
Ident="0" 'Sind sämtliche Zeilen gleich?
For i=1 to Ende1
If Zeile1(i)=Zeile2(i) then Ident=1+Ident
Next
If Ident=Ende1 then
MsgBox UV&"Datei1 = Datei2, sind völlig identisch !"&_
" "&UV,VbInformation,Titel : WScript.Quit
End If
End If
'"Ende" ist Länge der längeren "Datei2":
'***************************************
Ende=Ende2
'Zeilenunterschied der Dateien in Suche einplanen:
'*************************************************
'Folgende Spanne müsste beim Vergleich der Zeilen
'rückwärts und vorwärts ausreichend sein!?
Dazu=CInt(2*(Ende-Ende1))+50
'Leeren Zeilenüberhang für die Dateien schaffen:
'***********************************************
ReDim Preserve Zeile1(2*Ende)
For r=1+Ende1 to 2*Ende
Zeile1(r)=""
Next
ReDim Preserve Zeile2(2*Ende)
For r=1+Ende2 to 2*Ende
Zeile2(r)=""
Next
'Prüfen, ob die Dateien evtl. zu ungleich sind:
'**********************************************
Verschd="0"
x=1
Do until (x>200 or x>Ende1)
y=1
Do until (x>200 or y>Ende2)
If (Zeile1(x)=Zeile2(y) and Zeile1(x)<>"" and _
Left(Zeile1(x),1)<>"'" and LCase(Right(Zeile1(x),6)) _
<>"end if" and LCase(Right(Zeile1(x),4))<>"next" and _
LCase(Right(Zeile1(x),12))<>"wscript.quit" and _
LCase(Right(Zeile1(x),4))<>"else" and _
LCase(Right(Zeile1(x),7))<>"end sub" and _
LCase(Right(Zeile1(x),12))<>"end function" and _
LCase(Right(Zeile1(x),4))<>"loop") then Verschd=1+Verschd
y=y+1
Loop
x=x+1
Loop
'Abbruch, wenn viel zu wenige Gemeinsamkeiten bestehen:
'******************************************************
If (Verschd="0" or Verschd<=10) then MsgBox UV&VbTab&_
"Die Dateien sind viel zu "&_
"ungleich! "&UV,,Titel:WScript.Quit 'Abbruch!
'Zeit-Warnung, wenn beide Dateien sehr groß sind:
'************************************************
If Ende>1000 then MsgBox UV&VbTab&"Da die Dateien ziemlich "&_
"groß sind, "&UV&VbTab&"kann der Vergleich"&_
" etwas dauern!"&UV,VbSystemModal,Titel
'ZeilenX(r) nach Streichen der Leerstellen speichern:
'****************************************************
ReDim Preserve Zeilen1(Ende1)
For r=1 to Ende1
Zeilen1(r)=Zeile1(r)
Next
ReDim Preserve Zeilen2(Ende2)
For r=1 to Ende2
Zeilen2(r)=Zeile2(r)
Next
'In Zeilen1(i) Leerstellen u.ä. am Anfang streichen:
'***************************************************
For i=1 to Ende1
If Zeile1(i)<>"" then
Schluss="0"
k=1
Do until (k=Len(Zeile1(i))+1 or Schluss="1")
'Prüfen, ob anfangs Tabs/Leerstellen sind: streichen!
'****************************************************
If not (Mid(Zeile1(i),k,1)=" " or Mid(Zeile1(i),k,1)=" " _
or Mid(Zeile1(i),k,1)=" ") then
Schluss="1"
Zeile1(i)=Right(Zeile1(i),Len(Zeile1(i))-k+1)
End If
k=k+1
Loop
End If
Next
'In Zeilen2(i) Leerstellen u.ä. am Anfang streichen:
'***************************************************
For i=1 to Ende2
If Zeile2(i)<>"" then
Schluss="0"
k=1
Do until (k=Len(Zeile2(i))+1 or Schluss="1")
'Prüfen, ob anfangs Tabs/Leerstellen sind: streichen!
'****************************************************
If not (Mid(Zeile2(i),k,1)=" " or Mid(Zeile2(i),k,1)=" " _
or Mid(Zeile2(i),k,1)=" ") then
Schluss="1"
Zeile2(i)=Right(Zeile2(i),Len(Zeile2(i))-k+1)
End If
k=k+1
Loop
End If
Next
'############################################
'Datei für Angabe der Unterschiede festlegen und schreiben:
'**********************************************************
Datei=Left(Datei1,Len(Datei1)-4)&"-Vgl.txt"
Set File=Fso.OpenTextFile(Datei,2,true)
'Kopf der Unterschiede - Datei wird jetzt geschrieben,
'zunächst Dateien zeilenweise und nummeriert angeben !
'*****************************************************
File.WriteLine("")
File.WriteLine("")
File.WriteLine("Dies ist zeilenweise """&Datei1&"""")
File.WriteLine("**************************************************")
File.WriteLine("")
For a=1 to Ende1
File.WriteLine(a&VbTab&Zeilen1(a)) 'Bei VbTab Längenausgleich!
Next
File.WriteLine("")
File.WriteLine("")
File.WriteLine("################################################")
File.WriteLine("")
File.WriteLine("")
File.WriteLine("Dies ist zeilenweise """&Datei2&"""")
File.WriteLine("**************************************************")
File.WriteLine("")
For b=1 to Ende2
File.WriteLine(b&VbTab&Zeilen2(b))
Next
File.WriteLine("")
File.WriteLine("")
File.WriteLine("################################################")
File.WriteLine(" ################################################")
File.WriteLine("################################################")
File.WriteLine("")
File.WriteLine("")
File.WriteLine("Verglichen werden """&Datei1&"""")
File.WriteLine("und """&Datei2&"""")
File.WriteLine("")
File.WriteLine("Die Zahlen vorne sind Zeilen von Datei1 bzw. Datei2 ")
File.WriteLine("")
'Beide Dateien werden zeilenweise verglichen:
'********************************************
Plus1="0" 'Zusatzzeilen durch Einschübe in Datei1
Plus2="0" ' ... in Datei2
For i=1 to Ende '<<<<<< Suchschleife
If (i+Plus1>Ende1 or i+Plus2>Ende2) then Fertig 'beenden!
'Prüfen, wie weit ab dem Ort die Dateizeilen gleich sind:
'********************************************************
Ort=i
GleicheZeilen 'Sub-Programm aufrufen, s.u.
i=Stelle 'Neuen Startpunkt festlegen!
'Ab hier wieder ungleich!
Leerzeilen 'Evtl. Leerzeilen danach werden übersprungen:
'Besteht Änderung einer einzelnen Zeile in beiden Dateien?
'Einschübe in eine Datei oder Einschübe neben Änderungen??
'*********************************************************
Erfolg="0"
Aenderg 'Änderung, Einschübe, Änderung + Einschübe testen!
Stelle=1+i 'Evtl. Leerzeilen danach werden übersprungen!
Leerzeilen
Next '<<<<<<<< Ende der Suchschleife
'Sub-Programm zum Schließen dieses Programmes:
'*********************************************
Fertig
WScript.Quit
'############################################
'**************************************************
' *
' Als Nächstes die erforderlichen Sub - Programme *
' *
'**************************************************
Sub Leerzeilen
'Evtl. Leerzeilen danach überspringen:
'*************************************
If (Zeile1(Stelle+Plus1)="" or Zeile2(Stelle+Plus2)="") then
'Überprüfung von "Datei1" auf Leerzeilen:
'****************************************
Leer="0"
Plus="0"
k=0
Do until (Leer="1" or Stelle+Plus1+k>Ende1)
If Zeile1(Stelle+Plus1+k)="" then
Plus=1+Plus
else
Leer="1"
End If
k=k+1
Loop
If (Leer="1" and Plus<>"0") then Plus1=Plus1+Plus
'Überprüfung von "Datei2" auf Leerzeilen:
'****************************************
Leer="0"
Plus="0"
k=0
Do until (Leer="1" or Stelle+Plus2+k>Ende2)
If Zeile2(Stelle+Plus2+k)="" then
Plus=1+Plus
else
Leer="1"
End If
k=k+1
Loop
If (Leer="1" and Plus<>"0") then Plus2=Plus2+Plus
End If
End Sub
'############################################
Sub Fertig
'Unterschiede-Datei, Programm schließen, Ergebnis ausgeben:
'**********************************************************
File.Close
Set File=Nothing
'Datei mit Liste der Unterschiede öffnen, ggf. löschen(?):
'*********************************************************
Wss.Run "Notepad """&Datei&""" "
WScript.Sleep 500
'Frage, ob die ausgegebene Datei zu löschen ist:
'***********************************************
Ask=MsgBox(UV&UV&"Soll die Datei mit den Unterschieden "&_
"gelöscht werden ? "&UV&"Sie befindet"&_
" sich im Verzeichnis der ersten Datei!"&_
UV&UV,VbYesNo+VbDefaultButton2+VbCritical,Titel)
If Ask="7" then WScript.Quit 'Bei "Nein" Abbruch!
'Auf Wunsch Datei mit den Unterschieden löschen:
'***********************************************
Fso.DeleteFile Datei
WScript.Quit
End Sub
'############################################
Sub GleicheZeilen
'Prüfen, bis wohin "Datei1" und "Datei2" gleich sind:
'****************************************************
Schluss="0"
x=Ort
Do until (Schluss="1" or x+Plus1>Ende1 or x+Plus2>Ende2)
If Zeile1(x+Plus1)<>Zeile2(x+Plus2) then
Schluss="1"
Stelle=x 'Bei x-1 letztes Mal gleiche Zeilen!
If x>Ort then Exit Sub 'Falls gleiche Zeilen da!
End If
x=x+1
Loop
Stelle=Ort 'Wenn keine neuen gleichen Zeilen gefunden
End Sub
'############################################
Sub Aenderg 'Enthält ein Unter-Sub-Programm
'Prüfen, ob einzelne Zeile verändert wurde:
'******************************************
Erfolg="0"
If (Zeile1(i+Plus1)<>Zeile2(i+Plus2) and _
Zeile1(i+Plus1+1)=Zeile2(i+Plus2+1) and _
Zeile1(i+Plus1+1)<>"") then
File.WriteLine("")
File.WriteLine("####### Diese Einzelzeile wurde geändert: #######")
File.WriteLine((i+Plus1)&VbTab&Zeilen1(i+Plus1))
File.WriteLine((i+Plus2)&VbTab&Zeilen2(i+Plus2))
File.WriteLine("#################################################")
File.WriteLine("")
Plus1=1+Plus1
Plus2=1+Plus2
Erfolg="1"
Exit Sub 'Zurück !
End If
'******************************************************
'* *
'* Falls hier keine veränderte Einzelzeile vorliegt : * *
'* Testen, ob Einschübe zu finden sind oder geänderte *
'* Zeilen samt Einschüben zusammen vorliegen können : *
'* *
'******************************************************
WeiterSuchen 'Obiges in weiterem Sub-Programm testen
If Erfolg="1" then Exit Sub
End Sub
'############################################
Sub WeiterSuchen
If Zeile1(i+Plus1)<>Zeile2(i+Plus2) then
'Evtl. Einschub1 in "Datei1" ermitteln:
'**************************************
Neu1="0"
Gleich="0"
a=1
Do until (Gleich="1" or i+Plus1+a>Ende1 or a>Dazu)
If (Zeile1(i+Plus1+a)=Zeile2(i+Plus2) and _
Zeile2(i+Plus2)<>"") then Gleich="1"
a=a+1
Loop
If (a-1>0 and Gleich="1") then Neu1=a-1
'Evtl. Einschub2 in "Datei2" ermitteln:
'**************************************
Neu2="0"
Gleich="0"
If Zeile1(i+Plus1)<>Zeile2(i+Plus2) then
b=1
Do until (Gleich="1" or i+Plus2+a>Ende2 or b>Dazu)
If (Zeile1(i+Plus1)=Zeile2(i+Plus2+b) and _
Zeile1(i+Plus1)<>"") then Gleich="1"
b=b+1
Loop
If (b-1>0 and Gleich="1") then Neu2=b-1
End If
'Wenn welche gefunden, den sinnvolleren Einschub wählen:
'*******************************************************
If (Neu1>0 or Neu2>0) then
If ((Neu1>0 and Neu2=0) or Neu1<Neu2) then
Einschub1
Erfolg="1"
Exit Sub
End If
If ((Neu1=0 and Neu2>0) or Neu2<=Neu1) then
Einschub2
Erfolg="1"
Exit Sub
End If
End If
'Ein Einschub neben geänderten Zeilen in den Dateien,
'oder unterschiedliche Zeilenblöcke in den Dateien !?
'****************************************************
Gleich="0"
Grenz="0"
k=i+Plus1
Do until (k>i+Plus1+Dazu or k>Ende1 or Gleich="1")
'Beim Vergleich der Zeilen rückwärts und vorwärts schauen:
'*********************************************************
l=k-Dazu 'aber nicht vor letzte Gleichheit gehen:
If k-Dazu<i+Plus2 then l=i+Plus2
Do until (l>i+Plus2+Dazu or l>Ende2 or Gleich="1")
'Verhindern, dass '********* o.ä. zur Gleichheit führt:
'******************************************************
Stern="0"
Lang=Len(Zeile1(k))
'Zeile mit gleichen Zeichen muss mind. 4 Stellen haben:
'******************************************************
If Lang>=4 then
If (Mid(Zeile1(k),Lang-2,1)=Mid(Zeile1(k),Lang-1,1) and _
Mid(Zeile1(k),Lang-1,1)=Right(Zeile1(k),1)) then Stern="1"
End If
'Prüfen, ob Zeilen gleich sind:
'******************************
If (Zeile1(k)=Zeile2(l) and (Right(Zeile1(k),4) _
<>"("""")" and Zeile1(k)<>"" and Stern="0" and _
k>i+Plus1 and l>i+Plus2)) then
Gleich="1"
Erfolg="1"
End If
l=l+1
Loop
k=k+1
Loop
'Falls in den Dateien nur Leerzeilen zu finden:
'**********************************************
Nicht="0"
For a=i+Plus1-1 to k-1
If Zeile1(a)<>"" then Nicht="1"
Next
For b=i+Plus2-1 to l-1
If Zeile2(b)<>"" then Nicht="1"
Next
If Nicht="0" then
Plus1=Plus1+k-1-(i+Plus1) 'Verschiebungen notieren!
Plus2=Plus2+l-1-(i+Plus2)
Exit Sub
End If
'Falls nichts Gleiches mehr zu finden:
'*************************************
If k>Ende1 then
Grenz="1"
Gleich="1"
End If
'Wenn, dann bis zum Ende ungleiche Zeilen ausgeben:
'**************************************************
If Grenz="1" then
k=Ende1+2
l=Ende2+2
End If
'Unterschiede von "Datei1" und "Datei2" notieren:
'*************************************************
If Gleich="1" then
File.WriteLine("")
File.WriteLine("§§§§§§§ Die Unterschiede in Datei1 §§§§§§§")
If k-1=Ende1 then k=k-1 'Am Ende von "Datei1" um 1 zurücknehmen
For a=i+Plus1-1 to k-2 'bei k-2 schon gleiche Zeile gefunden !
File.WriteLine((a)&VbTab&Zeilen1(a))
Next
File.WriteLine("§§§§§§§ und Datei2 §§§§§§§")
If l-1=Ende2 then l=l-1 'Am Ende von "Datei2" um 1 zurücknehmen
For b=i+Plus2-1 to l-2 'bei l-2 schon gleiche Zeile gefunden !
File.WriteLine((b)&VbTab&Zeilen2(b))
Next
File.WriteLine("§§§§§§§ Dies waren die Unterschiede §§§§§§§")
File.WriteLine("")
Plus1=Plus1+k-1-(i+Plus1) 'Verschiebungen berücksichtigen!
Plus2=Plus2+l-1-(i+Plus2)
End If
End If
End Sub
'############################################
Sub Einschub1
'Erkannten Einschub1 aus "Datei1" schreiben:
'*******************************************
'Prüfen, ob nicht alles nur Leerzeilen waren:
'********************************************
Voll="0"
For z=1 to Neu1
If Zeile1(i+Plus1+z-1)<>"" then Voll="1"
Next
If Voll="0" then
Plus1=Plus1+Neu1 'Verschiebung durch Einschub2
Exit Sub 'bei Leerzeilen einen Abbruch
End If
File.WriteLine("")
File.WriteLine("Dies ist ein Einschub in die Datei1 : ")
File.WriteLine(">> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >> ")
For z=1 to Neu1
File.WriteLine((i+Plus1+z-1)&VbTab&Zeilen1(i+Plus1+z-1))
Next
File.WriteLine(">> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >> 1 >>")
File.WriteLine("")
Erfolg="1"
'Verschiebung durch den Einschub1 festhalten:
'********************************************
Plus1=Plus1+Neu1
End Sub
'############################################
Sub Einschub2
'Erkannten Einschub2 aus "Datei2" schreiben:
'*******************************************
'Prüfen, ob nicht alles nur Leerzeilen waren:
'********************************************
Voll="0"
For z=1 to Neu2
If Zeile2(i+Plus2+z-1)<>"" then Voll="1"
Next
If Voll="0" then
Plus2=Plus2+Neu2 'Verschiebung durch Einschub2
Exit Sub 'bei Leerzeilen einen Abbruch
End If
File.WriteLine("")
File.WriteLine("Dies ist ein Einschub in die Datei2 : ")
File.WriteLine(">> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >> ")
For z=1 to Neu2
File.WriteLine((i+Plus2+z-1)&VbTab&Zeilen2(i+Plus2+z-1))
Next
File.WriteLine(">> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >> 2 >>")
File.WriteLine("")
Erfolg="1"
'Verschiebung durch den Einschub2 festhalten:
'********************************************
Plus2=Plus2+Neu2
End Sub
#########################################################################
>>> dateienvergleich.vbs <<<
'*** v7.8 *** www.dieseyer.de *******************************
'
' Datei: dateienvergleich.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Vergleich zwei Dateien mit "fc /b %1 %2"
'
' Vergleicht, wie der Name bereits verrät, (zwei) Dateien -
' über eine Auswahl per Binär- oder Textvergleich. Dazu die
' beiden zu vergleichenden Dateien auf das Skript ziehen und
' fallen lassen (Drag & Drop). Wird das Skript (mit Doppel-
' klick) gestartet, bietet es an, das Windows-Explorer -
' Kontextmenü zu erweitern. Dann kann man im Explorer zwei
' Dateien markieren und (dann durch Klicken mit der rechten
' Maus-Taste und über 'Senden an') die markierten Dateien an
' das Skript übergeben.
' Das Skript verwendet das Befehlszeilenprogramm 'fc.exe',
' das beim zeilenweisen Vergleich auch nach mehren (unter-
' schiedlichen) Zeilen wieder synchronisiert - DAS wollte
' ich nicht nach programmieren.
'
'************************************************************
Option Explicit
Dim SendToLink, Text, Txt, TextX, i, lang
Dim WSHShell, fso, oArgs, ShellLink
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
SendToLink = "2 Dateien vergleichen"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
If oArgs.Count = 1 then
Text = Left( UCase(oArgs.item(0)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
End If
If not oArgs.Count = 2 then
SkriptInfo ' SUB Aufruf
Else
Text = vbCRLF
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if fso.FileExists( oArgs.item(i) ) then
TextX = TextX & """" & oArgs.item(i) & """ "
Text = Text & oArgs.item(i) & vbCRLF
End If
Next
End If
Text = "Die Dateien " & vbCRLF & Text & vbCRLF & "werden jetzt BINÄR verglichen." & vbCRLF & vbCRLF
Text = Text & ". . . oder reicht ein TEXT -Vergleich? [Yes] in 5 sec."
Text = WSHShell.Popup (Text, 10, WScript.ScriptName , 32+3 )
if Text = -1 then TextX = "%comspec% /c fc /N " & TextX
if Text = vbYes then TextX = "%comspec% /c fc /N " & TextX
if Text = vbNo then TextX = "%comspec% /c fc /B " & TextX
if Text = vbCancel then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 48
WScript.Quit
End If
TextX = TextX & " > """ & WScript.ScriptName & ".log"""
' WSHShell.Popup TextX, 10, WScript.ScriptName , 64
' WSHShell.run TextX , , True
WSHShell.run TextX , 7, True
TextX = "notepad """ & WScript.ScriptName & ".log"""
WSHShell.run TextX , , True
'***************************************************************
' ENDE - das eigentliche Skript endet
'***************************************************************
' WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende. " , 64
Text = ""
Text = Text & " " & vbCRLF
WScript.Quit
'*********************************
Sub SkriptInfo ' Sub Aufruf
'*********************************
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "ZWEI Dateien (wirklich genau 2 Dateien)" & vbCRLF
Text = Text & "mit der Maus auf das Skript ziehen und fallen lassen, " & vbCRLF
Text = Text & "oder dem Skript über 'Senden an' die Dateien bzw. " & vbCRLF
Text = Text & "Verzeichnisse übergeben. " & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende." , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & SendToLink & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
#########################################################################
>>> dateienverschieben-alteloeschen.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben-alteloeschen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Erstellt für www.roton.de
'
' Ursprungsskript:
' dateienalteliste.vbs
' mit der Prozedur AlteDateien( arrDateiLst, Alter, ZeitType )
'
' Erweiterung(en):
' - DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' aus dateienverschieben_zufall.vbs
' - DateiListeLoeschen( arrDateiLst )
' aus dateienaltdelete-3.vbs
' - Parameter für das ZielVerz.
' - Parameter um das Löschen zu aktivieren/deaktivieren (LoeschenAktiv = "YES")
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
' Für die Prozedur AlteDateien( arrDateiLst, Alter, ZeitType )
Const QuellVerz = "C:\dieseyer.de\scr"
Const Alter = 26
Const ZeitType = "d"
' Für die Prozedur DateienVerschiebenZufall( arrDateiLst, ZielVerz )
Const ZielVerz = "c:\temp.zw\zw"
' Für die Prozedur DateiListeLoeschen( arrDateiLst )
Const LoeschenAktiv = "YES"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
LogEintrag "050 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "051 :: LogDatei: " & LogDatei
LogEintrag "052 :: ZielVerz: """ & ZielVerz & "\"" "
LogEintrag "053 :: LogDatei: " & LogDatei
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "055 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'' arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
arrDateiLst = Dateilisteholen( QuellVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "064 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
' ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenZufall arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( ZielVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogEintrag "078 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
AlteDateien arrDateiLst, Alter, ZeitType
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateiListeLoeschen arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "096 :: " & WScript.ScriptName
LogEintrag "098 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateiListeLoeschen( arrDateiLst )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim i, m, n, z, Tst
i = 0 : m = 0 : n = 0 : z = 0
LogEintrag "110 :: Start der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
If LoeschenAktiv = "YES" Then LogEintrag "112 :: LÖSCHEN IST AKTIV - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
If LoeschenAktiv <> "YES" Then LogEintrag "113 :: LÖSCHEN IST DEAKTIVIERT - Die Variable ""LoeschenAktiv"" steht auf '" & LoeschenAktiv & "'"
' Dateinamen des Arrays testen und Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
On Error Resume Next
Tst = " - "
If LoeschenAktiv = "YES" Then fso.DeleteFile arrDateiLst( i )
If LoeschenAktiv <> "YES" Then LogEintrag "123 :: Datei( " & i & " ) wird NICHT gelöscht: " & arrDateiLst( i )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
LogEintrag "129 :: Datei( " & i & " ) nicht löschbar: " & arrDateiLst( i ) & " " & Tst
z = z + 1
Else
If LoeschenAktiv = "YES" Then n = n + 1 : LogEintrag "132 :: Datei( " & i + 1 & " ) gelöscht: " & arrDateiLst( i )
End If
Else
If Len( arrDateiLst( i ) ) > 3 Then
LogEintrag "136 :: Datei( " & i & " ) fehlt (kann daher nicht gelöscht werden): " & arrDateiLst( i )
Else
m = m + 1
' LogEintrag "139 :: Datei( " & i & " ): " & arrDateiLst( i )
End If
End If
Next
LogEintrag "144 :: " & n & " von " & i & " Dateien gelöscht."
LogEintrag "145 :: " & z & "x ist ein Fehler beim Löschen einer Datei aufgetreten."
LogEintrag "146 :: " & m & " Arrayeinträge waren leer bzw. enthielten keinen gültigen Dateinamen."
LogEintrag "147 :: Ende der Function-Prozedur 'DateiListeLoeschen( arrDateiLst )'"
End Function ' DateiListeLoeschen( arrDateiLst )
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine zufällige
' 5stellige Hex-Zahl eingefügt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "181 :: Start der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
LogEintrag "182 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "183 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "192 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "200 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "203 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
' Ergänzung ermitteln; 5stellige Hex-Zahl
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
Tst = UCase( fso.GetTempName ) ' ergibt z.B.: rad01443.tmp
Tst = Replace( Tst, ".TMP", "" ) ' ".tmp" entfernen
Tst = Mid( Tst, 4 ) ' ab der 4. Stelle, also nach "rad"
Tst = ZielVerz & "\" & ZielName & "_" & Tst & "." & ZielErw
If not fso.FileExists( Tst ) Then ZwName = Tst : Exit Do
Loop
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "239 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "240 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "242 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "246 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "248 :: Ende der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function AlteDateien( arrDateiLst, Alter, ZeitType )
'*********************************************************
' An die Prozedur
' AlteDateien( arrDateiLst, Alter, ZeitType )
' wird ein Array übergeben. Als Ergebnis wird dieses Array
' zurück gegeben, das nur die ausgewählten (bzw. alten)
' Dateien enthält - die anderen Array-Elemente sind leer.
'
' AlteDateien( arrDateiLst, Alter, ZeitType )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' Alter - Alter kann ein Datum oder eine Zahl sein;
' es kann ein - oder ein + davor stehen
'
' ZeitType - Datum als Alter:
' ZeitType kann "VOR" oder "NACH" enthalten;
' für z.B. "VOR" (dem) 03.10.89 (erstellt)
'
' ZeitType - Zahl als Alter: Für den ZeitType ist
' der Syntax der DateDiff-Funktion bindend:
' yyyy Jahr; q Quartal; m Monat
' d Tag; y Tag im Jahr;
' w Wochentag; ww Woche im Jahr
' h Stunde; n Minute; s Sekunde
'
' + heißt älter als (bzw. größer oder "NACH" ??? erstellt)
' - heißt jünger als (bzw. kleiner oder "VOR" ??? erstellt)
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst, Ttt, i
Dim ZeitBezug : ZeitBezug = "NACH"
LogEintrag "286 :: Start der Prozedur 'AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )'"
' LogEintrag "287 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' 'ZeitBezug' auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Left( Alter, 1 ) = "-" Then ZeitBezug = "VOR" : Alter = Mid( Alter, 2 )
If Left( Alter, 1 ) = "+" Then ZeitBezug = "NACH" : Alter = Mid( Alter, 2 )
If ZeitType = "VOR" Then ZeitBezug = "VOR"
If ZeitType = "NACH" Then ZeitBezug = "NACH"
' LogEintrag "296 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
' Prüfen, ob der Inhalt von 'Alter' verwendbar ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not IsDate( Alter ) Then Alter = CLng( Alter )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
' Alter enthält weder ein Datum noch eine Zahl; Alter ist ungültig!
WSHShell.Popup "Falscher Parameter für ""Alter"": " & vbCRLF & vbTab & "'" & Alter & "' führt zu" & vbCRLF & vbTab & Tst, 30, "306 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' LogEintrag "309 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter )
Tst = "-DATUM"
If InStr( Alter, ":" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "/" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "-" ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If InStr( Alter, "." ) Then Alter = CDate( Alter ) : Tst = "DATUM"
If Tst <> "DATUM" Then Alter = CLng( Alter)
LogEintrag "316 :: ZeitBezug: " & ZeitBezug & " Alter: " & Alter & " ZeitType: " & ZeitType & " VarType( Alter ): " & VarType( Alter ) & " - " & Tst
' Dateinamen des Arrays testen und ggf. im Array löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
Tst = fso.GetFile( arrDateiLst( i ) ).DateLastModified
Ttt = DateDiff( ZeitType, Tst, now() )
If IsDate( Alter ) Then
' arrDateiLst( i ) = Clng( Tst - Alter ) & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Tst - Alter < 0 Then arrDateiLst( i ) = "" ' & "N " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Tst - Alter > 0 Then arrDateiLst( i ) = "" ' & "V " & arrDateiLst( i )
Else
' arrDateiLst( i ) = Ttt & vbTab & Tst & vbTab & arrDateiLst( i )
If ZeitBezug = "NACH" AND Ttt < Alter Then arrDateiLst( i ) = "" ' & "n " & arrDateiLst( i )
If ZeitBezug = "VOR" AND Ttt > Alter Then arrDateiLst( i ) = "" ' & "v " & arrDateiLst( i )
End If
'DateDiff(Intervall, Datum1, Datum2 [,ErsterWochentag[,ErsteWocheimJahr]] )
'Die Syntax der DateDiff-Funktion besteht aus folgenden
Next
LogEintrag "337 :: Start der Prozedur 'AlteDateien( arrDateiLst, " & Alter & ", " & ZeitType & " )'"
End Function ' AlteDateien( arrDateiLst, Alter, ZeitType )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "388 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "389 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "407 :: Start der Prozedur 'Dateilisteholen( " & Verz & " )'"
LogEintrag "408 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "417 :: i = " & i & vbTab & DateilisteholenX(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
LogEintrag "425 :: Ende der Prozedur 'Dateilisteholen( " & Verz & " )'"
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienverschieben_lfd.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben_lfd.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' DateienVerschiebenLFD() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenLFD( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; nach der letzten, die vorhandenen
' ist: Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt
' (von t.txt) vorhanden, wird t_009.txt, nicht
' t_003.txt, erstellt.
'
' Existiert t_999.txt, gibt es eine Fehlermeldung und
' die Datei t_999.txt wird überschrieben!
'
' Da für jede Datei geprüft wird, ob es welche mit
' den Zahlen zw. 000 undd 999 gibt, ist das Skript
' sehr langsam.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const ZielVerz = "D:\temp.zw\zw"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "059 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
'LogEintrag "070 :: arrDateiAlt = DateienAlte( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenLFD arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "082 :: " & WScript.ScriptName
LogEintrag "084 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenLFD() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenLFD( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; nach der letzten, die vorhandenen
' ist: Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt
' (von t.txt) vorhanden, wird t_009.txt, nicht
' t_003.txt, erstellt.
'
' Existiert t_999.txt, gibt es eine Fehlermeldung und
' die Datei t_999.txt wird überschrieben!
'
' Da für jede Datei geprüft wird, ob es welche mit
' den Zahlen zw. 000 undd 999 gibt, ist das Skript
' sehr langsam.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "129 :: Start der Function-Prozedur 'Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )'"
LogEintrag "130 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "131 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "140 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "148 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "151 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
Tst = ZielVerz & "\" & ZielName & "." & ZielErw
z = 0
' 3stellige Zahl ermitteln
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ttt = "-OK"
Do
If not fso.FileExists( Tst ) AND Ttt = "-OK" Then ZwName = Tst : Ttt = "OK"
If fso.FileExists( Tst ) Then Ttt = "-OK" ' : MsgBox Tst, , "181 :: "
z = z + 1 : Txt = z : If Len( Txt ) < 3 Then Txt = "0" & Txt : If Len( Txt ) < 3 Then Txt = "0" & Txt
Tst = ZielVerz & "\" & ZielName & "_" & Txt & "." & ZielErw
If Txt = "999" AND Ttt = "-OK" Then ZwName = Tst : Exit Do
If Txt = "999" Then Exit Do
Loop
If fso.FileExists( ZwName ) Then LogEintrag "188 :: Vorhandene Datei wird überschrieben: """ & ZwName & """ "
If fso.FileExists( ZwName ) Then WSHShell.Popup "Vorhandene Datei wird überschrieben: """ & ZwName & """ ", 3, "189 :: " & WScript.ScriptName
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "194 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "195 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "197 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "201 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "203 :: Ende der Function-Prozedur 'Function DateienVerschiebenLFD( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenLFD( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "254 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "255 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "273 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "282 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienverschieben_nr.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben_nr.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' DateienVerschiebenNR() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenNR( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; die erste, die möglich ist:
' Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt (von
' t.txt) vorhanden, wird t_003.txt, nicht t_009.txt,
' erstellt.
'
' Sind alle Dateien bis t_999.txt, gibt es eine Fehler-
' meldung und die Datei t_999.txt wird überschrieben!
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const ZielVerz = "D:\temp.zw\zw"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "055 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
'LogEintrag "066 :: arrDateiAlt = DateienAlte( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenNR arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "078 :: " & WScript.ScriptName
LogEintrag "080 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenNR( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenNR() arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenNR( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine 3stellige
' Zahl eingefügt; die erste, die möglich ist:
' Sind t_000.txt,t_001.txt, t_002.txt, t_008.txt (von
' t.txt) vorhanden, wird t_003.txt, nicht t_009.txt,
' erstellt.
'
' Sind alle Dateien bis t_999.txt, gibt es eine Fehler-
' meldung und die Datei t_999.txt wird überschrieben!
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "121 :: Start der Function-Prozedur 'Function DateienVerschiebenNR( arrDateiLst, ZielVerz )'"
LogEintrag "122 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "123 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "132 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "140 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "143 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
Tst = ZielVerz & "\" & ZielName & "." & ZielErw
z = 0
' 3stellige Zahl ermitteln
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
If not fso.FileExists( Tst ) Then ZwName = Tst : Exit Do
z = z + 1 : Txt = z : If Len( Txt ) < 3 Then Txt = "0" & Txt : If Len( Txt ) < 3 Then Txt = "0" & Txt
Tst = ZielVerz & "\" & ZielName & "_" & Txt & "." & ZielErw
Loop
If fso.FileExists( ZwName ) Then LogEintrag "176 :: Vorhandene Datei wird überschrieben: """ & ZwName & """ "
If fso.FileExists( ZwName ) Then WSHShell.Popup "Vorhandene Datei wird überschrieben: """ & ZwName & """ ", 3, "177 :: " & WScript.ScriptName
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "182 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "183 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "185 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "189 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "191 :: Ende der Function-Prozedur 'Function DateienVerschiebenNR( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenNR( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "242 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "243 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "261 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "270 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienverschieben_zufall.vbs <<<
'*** v7.C *** www.dieseyer.de ****************************
'
' Datei: dateienverschieben_zufall.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' An die Prozedur
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine zufällige
' 5stellige Hex-Zahl eingefügt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
'
'*********************************************************
Option Explicit
' ~~~ Beginn der Definition der Parameter~~~~~~~~~~~~~~~~~
Const QuellVerz = "D:\dieseyer.neu\css"
Const ZielVerz = "D:\temp.zw\zw"
' ~~~ End der Definition der Parameter~~~~~~~~~~~~~~~~~~~~
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
If not fso.FolderExists( QuellVerz ) Then WSHShell.Popup "Falscher Parameter für ""QuellVerz"": " & vbCRLF & vbTab & "'" & QuellVerz & "'", 30, "049 :: ENDE - " & WScript.ScriptName : WScript.Quit
Dim arrDateiLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( "d:\dieseyer.neu\#include.ph5" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
'LogEintrag "060 :: arrDateiAlt = DateienAlte( arrDateiLst, " & Alter & ", " & ZeitType & " )" & vbCRLF
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateienVerschiebenZufall arrDateiLst, ZielVerz
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrDateiLst )
' CreateObject("WScript.Shell").Run "notepad " & LogDatei
WSHShell.Popup "= = = E N D E = = =", 2, "072 :: " & WScript.ScriptName
LogEintrag "074 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.C *** www.dieseyer.de ****************************
Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*********************************************************
' An die Prozedur
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' wird ein Array mit Dateinamen übergeben. Die Dateien
' werden in das ZielVerzeichnis verschoben.
'
' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
' arrDateiLst - wenn die Variable kein Array ist,
' wird ein Fehler angezeigt
' ZielVerz - wird erstellt, sofern nicht vorhanden;
' ein Fehler wird zurück gegeben, wenn das Laufwerk
' bzw. der Freigabename eines Netzaufwerks nicht
' vorhanden ist; es muss ein Verz. im Laufwerk
' bzw. im Freigabename angegeben werden.
'
' In den Dateinamen wird vor der Endung eine zufällige
' 5stellige Hex-Zahl eingefügt.
'
' z.Z. kopiert das Skript - kein Verschieben!
' Es müssen die beiden Zeile getauscht werden:
' fso.MoveFile arrDateiLst( i ), ZwName
' fso.CopyFile arrDateiLst( i ), ZwName
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
If Right( ZielVerz, 1 ) = "\" Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) -1 )
LogEintrag "109 :: Start der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
LogEintrag "110 :: UBound( arrDateiLst ): " & UBound( arrDateiLst )
LogEintrag "111 :: ZielVerz: """ & ZielVerz & "\"" "
Dim i, n, z, Tst, Txt, Ttt, ZwLaufw, ZielDatei, ZielName, ZielErw, ZwName
' Laufwerk des ZielVerz auf Existens prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
If Left( ZielVerz, 2 ) = "\\" Then Txt = Mid( ZielVerz, 3 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then Txt = Mid( ZielVerz, 4 )
If Txt = "" Then WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbTab & "'" & ZielVerz & "'", 30, "120 :: ENDE - " & WScript.ScriptName : WScript.Quit
Tst = Split( Txt, "\" )
If Left( ZielVerz, 2 ) = "\\" Then ZwLaufw = "\\" & Tst( 0 ) & "\" & Tst( 1 )
If Mid( ZielVerz, 2, 2 ) = ":\" Then ZwLaufw = Left( ZielVerz, 2 )
If fso.FolderExists( ZwLaufw ) Then
Else
WSHShell.Popup "Falscher Parameter für ""ZielVerz"": " & vbCRLF & vbCRLF & vbTab & "'" & ZielVerz & "'" & vbCRLF & vbCRLF & vbTab & "'" & ZwLaufw & "' ist nicht erreichbar!", 30, "128 :: ENDE - " & WScript.ScriptName : WScript.Quit
End If
' MsgBox "ZwLaufw: " & ZwLaufw & vbCRLF & " => UBound( Tst ) = " & UBound( Tst ) & vbCRLF & Txt & vbCRLF & ZwLaufw & Txt, , "131 :: "
' Unterverzeichnis(se) zum ZielVerz testen, ggf. erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Replace( ZielVerz, ZwLaufw & "\" , "" )
Tst = Split( Txt, "\" ) : i = 0
Txt = ZwLaufw
Do
If i > UBound( Tst ) Then Exit Do
Txt = Txt & "\" & Tst( i )
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
i = i + 1
Loop
n = 0
' Dateien (kopieren ) verschieben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
If fso.FileExists( arrDateiLst( i ) ) Then
ZielName = fso.GetBaseName( arrDateiLst( i ) )
ZielErw = fso.GetExtensionName( arrDateiLst( i ) )
ZielDatei = ZielName & "-" & ZielErw
' Ergänzung ermitteln; 5stellige Hex-Zahl
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
Tst = UCase( fso.GetTempName ) ' ergibt z.B.: rad01443.tmp
Tst = Replace( Tst, ".TMP", "" ) ' ".tmp" entfernen
Tst = Mid( Tst, 4 ) ' ab der 4. Stelle, also nach "rad"
Tst = ZielVerz & "\" & ZielName & "_" & Tst & "." & ZielErw
If not fso.FileExists( Tst ) Then ZwName = Tst : Exit Do
Loop
' fso.MoveFile arrDateiLst( i ), ZwName
fso.CopyFile arrDateiLst( i ), ZwName
n = n + 1
' LogEintrag "167 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & ZielName & "." & ZielErw & """ "
LogEintrag "168 :: " & n & ". Datei erstellt: """ & ZwName & """ aus """ & arrDateiLst( i ) & """ "
Else
If Len( arrDateiLst( i ) ) > 3 Then LogEintrag "170 :: (" & i & " ) Datei fehlt: " & arrDateiLst( i )
End If
Next
LogEintrag "174 :: " & n & " von " & UBound( arrDateiLst ) + 1 & " Datei(en) erstellt in: """ & ZielVerz & "\"" "
LogEintrag "176 :: Ende der Function-Prozedur 'Function DateienVerschiebenZufall( arrDateiLst, ZielVerz )'"
End Function ' DateienVerschiebenZufall( arrDateiLst, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function ArrayZeigen( InArray )
'*********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
LogEintrag "227 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "228 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
LogEintrag "246 :: Ausgeschl: " & Ausgeschl
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "255 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v7.C *** www.dieseyer.de ****************************
Sub LogEintrag( LogTxt )
'*********************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
#########################################################################
>>> dateienvonheute.vbs <<<
'v3.3*****************************************************
' File: DateienVonHeute.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle Dateien, bei denen das Änderungsdatum
' dem aktuellen Datum entspricht
'*********************************************************
Option Explicit
Dim WSHShell, fso
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, Text, Path
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Path = "d:\setup"
Path = "." ' Verzeichnis, in dem sich das Skript befindet
Path = "c:\temp"
if not fso.FolderExists( Path ) then
MsgBox UCase(Path) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Text = UCase( Path ) & " enthält folgende Dateien von heute:" & vbCRLF
Set oFolders = fso.GetFolder( Path )
Set oFiles = oFolders.Files
For Each i In oFiles
if FormatDateTime( i.DateLastModified ,2) = FormatDateTime( now() ,2) then
Text = Text & i.Name & vbTab & FormatDateTime( i.DateLastModified ,2) & vbCRLF
End If
Next
Set oFiles = nothing
Set oFolders = nothing
MsgBox Text
' i.Path
' i.Name
' i.Type
' i.DateCreated
' i.DateLastAccessed
' i.DateLastModified
' i.Size
#########################################################################
>>> dateierstellt.vbs <<<
Option Explicit
Dim Tst
Tst = "c:\1test"
Tst = "D:\temp.zw\"
Tst = "D:\temp.zw"
Tst = FileCreationEvent( ".", Tst )
MsgBox "=>" & Tst & "<=", , "0005 :: "
'**************************************************************
Function FileCreationEvent( PC, FolderOnPC)
'**************************************************************
Dim Txt
FolderOnPC = Replace( FolderOnPC, "\", "\\\\" )
' MsgBox "FolderOnPC: " & FolderOnPC, , "0012 :: "
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colMonitoredEvents : Set colMonitoredEvents = objWMIService.ExecNotificationQuery ("SELECT * FROM __InstanceCreationEvent WITHIN 10 WHERE Targetinstance ISA 'CIM_DirectoryContainsFile' and TargetInstance.GroupComponent= 'Win32_Directory.Name=""" & FolderOnPC & """'")
Txt = ""
Dim objLatestEvent
Do
Set objLatestEvent = colMonitoredEvents.NextEvent
Txt = Txt & vbCRLF & Now() & vbTab & objLatestEvent.TargetInstance.PartComponent
MsgBox Txt, 4096, "0020 :: "
Loop
End Function ' FileCreationEvent( PC, FolderOnPC)
#########################################################################
>>> dateierweiterung-1zeichen.vbs <<<
'v5.1*****************************************************
' File: DateiErweiterung-1Zeichen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Ändert von allen Dateien in einem Verzeichnis die
' Dateierweiterung auf 1 Zeichen ( tst.txt ==> tst.t )
'*********************************************************
Option Explicit
Dim WSHShell, fso
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, Text, Pfad, ZielDatei, Datei(), DateiX
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet
Pfad = "c:\test\zw"
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
' Dateiliste
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
ReDim Preserve Datei(i)
Datei(i) = DateiX.Name
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' Dateien umbenennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = LBound(Datei) to UBound(Datei)
if Fso FileExists( Datei(i) ) Then
ZielDatei = Pfad & "\" & fso.GetBaseName( Datei(i) ) & "." & Left( fso.GetExtensionName( Datei(i) ), 1)
if UCase( Pfad & "\" & Datei(i) ) = UCase( ZielDatei ) then
Text = Text & Pfad & "\" & Datei(i) & vbTab & " unverändert?!" & vbCRLF
Else
if fso.FileExists ( ZielDatei ) then
if vbYes = MsgBox (" Zieldatei" & vbCRLF & UCase( ZielDatei ) & vbCRLF & "existiert bereits und wird gelöscht!" , 4 , WScript.ScriptName ) then
fso.DeleteFile ZielDatei, True
fso.MoveFile Pfad & "\" & Datei(i) , ZielDatei
Text = Text & Pfad & "\" & Datei(i) & vbTab & " doppel ==> ! " & ZielDatei & vbCRLF
End If
Text = Text & Pfad & "\" & Datei(i) & vbTab & " Zieldatei nicht überschrieben! " & vbCRLF
Else
fso.MoveFile Pfad & "\" & Datei(i) , ZielDatei
Text = Text & Pfad & "\" & Datei(i) & " ==> " & ZielDatei & vbCRLF
End If
End If
End If
Next
' Was angerichtet wurde wird angezeigt:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox "In " & UCase(Pfad) & " wurden folgende Dateien umbenannt:" & vbCRLF & vbCRLF & Text, , WScript.Scriptname
Text = ""
WScript.Quit
#########################################################################
>>> dateiliste-nach-datum.vbs <<<
'v5.9********************************************************
' File: dateiliste-nach-datum.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt die Dateien eines Ordners nach Änderungsdatum sortiert an.
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Pfad, Ttt, Txt, Tst, i
Dim oFolders, oFiles, DateiX
Pfad = "c:\"
' Dateiliste => http://dieseyer.de/scr-html/datei-verzeichnis-liste.html:
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
Ttt = DateiX.DateLastModified
' Ttt = "22.6.2005 17:22:11"
' Ttt = "2005-06-22 17:22:12"
Tst = DateDiff( "s", CDate( Ttt ), Now() )
Txt = String( 11 - Len( Tst ), "0" ) & Tst
' MsgBox Ttt & vbCRLF & CDate( Ttt ) & vbCRLF & Tst & vbCRLF & Txt
ReDim Preserve Datei(i)
Datei(i) = Txt & DateiX.Name & " " & vbTab & "letzte Änderung: " & Ttt
i = i + 1
Next
Set oFiles = nothing
Set oFolders = nothing
' sortieren => http://dieseyer.de/dse-wsh-scr-d.html#sortbub
QuickSort Datei, LBound(Datei), UBound(Datei)
Txt = ""
' korregieren:
For i = LBound( Datei ) to UBound( Datei )
Datei(i) = Mid ( Datei(i), 12 )
Txt = Txt & Datei(i) & vbCRLF
Next
MsgBox Txt, , WScript.ScriptName
function QuickSort(vntArray, intVon, intBis) ' funtion Anfang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' Der gute, alte QuickSort-Algorithmus als Windows-Script. c't 5/2002
' Copyright Ralf Nebelo/c't
' Private Sub QuickSort(vntArray, intVon, intBis)
Dim i, j
Dim vntTestWert, intMitte, vntTemp
If intVon < intBis Then
intMitte = (intVon + intBis) \ 2
vntTestWert = vntArray(intMitte)
i = intVon
j = intBis
Do
Do While UCase( vntArray(i) ) < Ucase( vntTestWert )
' Do While vntArray(i) < vntTestWert
i = i + 1
Loop
Do While UCase( vntArray(j) ) > Ucase( vntTestWert )
' Do While vntArray(j) > vntTestWert
j = j - 1
Loop
If i <= j Then
vntTemp = vntArray(j)
vntArray(j) = vntArray(i)
vntArray(i) = vntTemp
i = i + 1
j = j - 1
End If
Loop Until i > j
If j <= intMitte Then
Call QuickSort(vntArray, intVon, j)
Call QuickSort(vntArray, i, intBis)
Else
Call QuickSort(vntArray, i, intBis)
Call QuickSort(vntArray, intVon, j)
End If
End If
end Function ' QuickSort(vntArray, intVon, intBis)
#########################################################################
>>> dateiliste-nach-datum2.vbs <<<
'v5.9********************************************************
' File: dateiliste-nach-datum2.vbs
' Autor: "TheDude"
' dieseyer.de
'
' Zeigt die Dateien eines Ordners nach Änderungsdatum sortiert an.
'************************************************************
' "TheDude" : http://source-center.de/forum/showthread.php?postid=30837#post30837
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim pf : Set pf = fso.GetFolder("c:\").SubFolders
Dim datalist : Set datalist = CreateObject("ADOR.Recordset")
Dim f, Txt
datalist.Fields.Append "p",200,255
datalist.Fields.Append "lm",200,255
datalist.Open
For Each f In pf
datalist.AddNew Array("p","lm"), Array(f.path,DateDiff("s","01/01/1970 00:00:00",f.DateLastModified))
Next
datalist.Sort = "lm DESC"
Do While Not datalist.EOF
' Txt = Txt & datalist("p") & vbTab & datalist("lm") & vbCRLF
Txt = Txt & datalist("lm") & vbTab & datalist("p") & vbCRLF
datalist.MoveNext
Loop
MsgBox Txt, , WScript.ScriptName
#########################################################################
>>> dateilisteholenmitdatumundname.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: dateilisteholenmitdatumundname.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit
Dim Tst
Tst = DateilisteHolenMitDatumUndName( "c:\windows\", "KB956" )
Call ArrayZeigen( Tst )
Call ArrayZeigen( DateilisteHolenMitDatumUndName( "c:\windows\", "" ) )
Wscript.Quit
'*** v9.3 *** www.dieseyer.de ******************************
Function DateilisteHolenMitDatumUndName( Verz, DNA )
'***********************************************************
' Die Prozedur
' DateilisteHolenMitDatumUndName( Verz, DNA )
' gibt ein Array mit dem Dateinamen (ohne Verzeichnis) von
' allen Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind - vor dem Dateinamen steht das Änderungsdatum
' (Datum & Uhrzeit; ähnlich DMTF). Ein rekursives Auflisten
' der Datein in Unterverzeichnissen erfolgt nicht!
' DNA: DateiNamenAnfang; z.B. alle Dateien, die mit "KB" beginnen
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Dim i, oFolder, oFiles, DateiX, ZeitPkt, Tst, Txt, errTst
ReDim Preserve DateilisteholenX( 0 )
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
If InStr( UCase( DateiX.Name ), UCase( DNA ) ) = 1 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX( i )
On Error Resume Next
' Tst = fso.GetFile( DateiX & ".dd" ).DateLastModified
Tst = fso.GetFile( DateiX ).DateLastModified
errTst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( errTst ) > 5 Then
DateilisteholenX( i ) = "Fehler: PC nicht (mehr) erreichbar um " & now()
DateilisteHolenMitDatumUndName = DateilisteholenX
Exit Function
End If
ZeitPkt = Year( Tst )
Txt = Month( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Day( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Hour( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Minute( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
Txt = Second( Tst ) : If Len( Txt ) < 2 Then Txt = "0" & Txt
ZeitPkt = ZeitPkt & Txt
DateilisteholenX( i ) = ZeitPkt & "~" & DateiX.Name
i = i + 1
End If
End If
Next
Set oFiles = nothing
Set oFolder = nothing
DateilisteHolenMitDatumUndName = DateilisteholenX
End Function ' DateilisteHolenMitDatumUndName( Verz, DNA )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "131 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> dateilisteholennachname.vbs <<<
'*** v9.1 *** www.dieseyer.de ******************************
'
' Datei: dateilisteholennachname.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit
Dim Tst
Tst = DateilisteHolenNachName( "c:\windows\", "KB956", "log" )
Call ArrayZeigen( Tst )
Wscript.Quit
'*** v9.1 *** www.dieseyer.de ******************************
Function DateilisteHolenNachName( Verz, DNA, DNX )
'***********************************************************
' Die Prozedur
' DateilisteHolenNachName( Verz, DNA, DNX )
' gibt ein Array mit dem Dateinamen (mit Verzeichnis) von
' allen Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind.
' DNA: DateiNamenAnfang
' DNX: DateiNamenErweiterung (Extension)
' Ein rekursives Auflisten der Datein in Unterver-
' zeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Dim i, oFolder, oFiles, DateiX, ZeitPkt, Tst, Txt, errTst
ReDim Preserve DateilisteholenX( 0 )
Set oFolder = fso.GetFolder( Verz )
Set oFiles = oFolder.Files
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
Tst = LCase( fso.GetExtensionName( DateiX ) ) ' : MsgBox Tst, , "047 :: " : WScript.Quit
If Tst = DNX and InStr( UCase( DateiX.Name ), UCase( DNA ) ) = 1 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX( i )
DateilisteholenX( i ) = DateiX
i = i + 1
End If
End If
Next
Set oFiles = nothing
Set oFolder = nothing
DateilisteHolenNachName = DateilisteholenX
End Function ' DateilisteHolenNachName( Verz, DNA, DNX )
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
MsgBox TxtOben , , "107 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
#########################################################################
>>> dateinachwortdurchsuchen.vbs <<<
'v7.8*****************************************************
' File: dateinachwortdurchsuchen.vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Beliebige Datei auf dieses Programm ziehen und loslassen!
' Ein zu suchendes Wort eingeben, groß und klein wichtig !!
' Die Zeilen mit dem gesuchten Wort werden dann mit der Num-
' merierung angezeigt!
'*********************************************************
'CopyRight W. Schmelz, 09.08.2007
'Objekte für das Programm bereit stellen:
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Arg=Wscript.Arguments
Titel=" Wort in Datei suchen !"
'Aufgesetzte Datei ermitteln:
For i=0 to Arg.Count -1
Datei=Arg.Item(i)
Next
'Falls keine Datei aufgesetzt wurde:
UV=VbCR&VbCR
If Datei="" then MsgBox UV&VbCR&_
" Bitte eine Datei aufsetzen,"&UV&_
" in der Wort gesucht werden soll ! "&_
UV&VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Abfrage des zu suchenden Wortes oder Abbruch:
Wort=InputBox(UV&UV&_
" Geben Sie das zu suchende Wort ein !"&UV&_
" Achten Sie auf kleine / große Buchstaben !"&UV&UV,Titel)
If Wort="" then WScript.Quit
'Aufgesetzte Datei öffnen und lesen:
Set File=Fso.OpenTextFile(Datei,1,true)
i=1
Do until File.AtEndOfStream
ReDim Preserve Zeile(i)
Zeile(i)=File.ReadLine
i=i+1
Loop
Ende=i-1
File.Close
Set File=Nothing
'Suche des Wortes in den Zeilen:
Hier=""
Zahl="0" 'Zahl der Fundstellen
For i=1 to Ende
k=1
Do until k>Len(Zeile(i))-Len(Wort)+1
If Mid(Zeile(i),k,Len(Wort))=Wort then
Hier=Hier&" | "&i
Zahl=Zahl+1 'Wie oft "Wort" gefunden ?
End If
k=k+1
Loop
Next
'Ende abschneiden !
If Len(Hier)>4 then Hier=Right(Hier,Int(Len(Hier)-3))
'Falls nichts zu finden war:
If Hier="" then MsgBox UV&VbCR&"Das Wort "" "&_
Wort&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Zeilen mit Nr. versehen:
For i=1 to Ende
Zeile(i)=i&VbTab&Zeile(i) 'VbTab gibt spaltenweise Anzeige, nicht " "!
Next
'Ausgabe der Fundstellen:
'MsgBox UV&UV&" Das Wort "" "&Wort&_
' " "" befindet sich in Zeile : "&UV&UV&_
' " "&Hier&UV&UV,VbInformation,Titel
'Aufsplittung der Fundorte in Ort( ), beginnt mit Ort(0) !
Ort=Split(Hier," | ")
'Ausgabedatei festlegen und gefundene Zeilen mit Nr. hinein schreiben:
Stamm=Fso.GetParentFolderName(Datei)
Datei=Fso.GetBaseName(Datei)&"-Such.txt"
Datei=Stamm&"/"&Datei
Set File=Fso.OpenTextFile(Datei,2,true)
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine("Das Wort "" "&Wort&" "" steht in folgenden Zeilen:")
File.WriteLine("************************************************")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
i=0
Do until i=Zahl 'Beginn mit i=0 !!
File.WriteLine(" ")
File.WriteLine(Zeile(Ort(i)))
i=i+1
Loop
File.Close
Set File=Nothing
'Bei Erfolg die Datei mit den Zeilen-Nr. anzeigen und diese löschen:
Wss.Run "Notepad """&Datei&""" "
WScript.Sleep 1500
'Frage, ob Ausgabe-Datei gelöscht werden soll:
Ask=MsgBox(UV&UV&_
"Soll diese Datei mit den Fundorten gelöscht werden ? "&_
UV&"Sie steht im Verzeichnis dieser aufgesetzten Datei!"&UV&_
UV,VbYesNo+VbDefaultButton2+VbCritical,Titel)
If Ask="7" then WScript.Quit ' Bei "Nein" Abbruch !
'Sonst die Fundort-Datei löschen:
WScript.Sleep 1000
Fso.DeleteFile Datei
#########################################################################
>>> dateinameninkleinbuchstaben.vbs <<<
'v3.5*****************************************************
' File: DateienMitKleinbuchstaben.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Alle Dateien in einem Verzeichnis erhalten gleichen
' Dateinamen wie bisher, aber mit Kleinbuchstaben.
'*********************************************************
Option Explicit
Dim WSHShell, fso
Dim oFolders, oSubFolder, oFiles, Folder
Dim i, LaufW, Pfad, DateiX, VerzX
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
LaufW = Left( UCase( WScript.ScriptFullName), 2)
Pfad = LaufW & "\dieseyer.neu\scr\backup"
Pfad = LaufW & "\dieseyer.neu\scr"
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
' Dateiliste an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
i = i + 1
ReDim Preserve Datei(i)
Datei(i) = DateiX.Path
Next
Set oFiles = nothing
Set oFolders = nothing
' Datei-Array - Dateien
' 1. Datei nach *.?? umbenennen
' 2. Datei nach *.* mit Kleinbuchstaben umbenennen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 1 to UBound( Datei )
set DateiX = fso.GetFile( Datei(i) )
DateiX.move ( Datei(i) & "-" )
set DateiX = nothing
set DateiX = fso.GetFile( Datei(i) & "-" )
DateiX.move ( LCase( Datei(i) ) )
set DateiX = nothing
Next
MsgBox "In " & Pfad & " wurden von " & i & vbCRLF & "Dateien der Dateiname in Kleinbuchstaben geändert."
#########################################################################
>>> dateinamenlangdir.vbs <<<
'*** v10.6 *** www.dieseyer.de *****************************
' File: DateiNamenLangDIR.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverzeichnis nach Dateien, deren Name inkl.
' kompletter Pfadangabe länger als 250 Zeichen ist.
'
' Neuu in v10.5: zu testendes Verzeichnis auf VBS ziehen und
' fallen lassen.
'
' Neu in v9.4: 'Browse For Folder', wenn die Variable
' "LaufWerk" leer ist.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Args : Set Args = Wscript.Arguments
Dim Tst, Text, i, iDatei, iVerz, iLang, iAnz, MaxAnz, LaufWerk, Modus1, Modus2, Zeit, DirTmp
Dim fo, fi
Dim LogDatei
iLang = 0
Modus1 = 0
Modus2 = 0
MaxAnz = 200
LaufWerk = ""
For i = 0 to Args.Count - 1 ' hole alle Argumente
LaufWerk = LaufWerk & " " & Args( i )
Next
LaufWerk = Trim( LaufWerk )
If LaufWerk = "" Then LaufWerk = BrowseForFolder( "Verzeichnis auswählen:", 9+16384, 0 )
' Pfad erreichbar?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FolderExists( Laufwerk ) Then
Else
MsgBox vbTab & "= = = F E H L E R = = =" & vbCRLF & vbCRLF & ">" & Laufwerk & "<" & vbCRLF & vbCRLF & vbTab & "ist nicht erreichbar!", , "045 :: " & WScript.ScriptName
WScript.Quit
End If
If Right( LaufWerk, 1 ) = "\" Then LaufWerk = Left( LaufWerk, Len( LaufWerk ) - 1 ) ' ohne \ am Ende
' LogDatei festlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
LogDatei = WScript.ScriptFullName
LogDatei = Left( LogDatei, InStrRev( LogDatei, "." ) - 1 )
' MsgBox LogDatei, , "056 :: " : WScript.Quit
If Mid( Laufwerk, 2, 1 ) = ":" Then
Tst = Mid( Laufwerk, 1, 1 ) & "-" & Mid( Laufwerk, InStrRev( Laufwerk, "\" ) + 1 )
Else
Tst = Mid( Laufwerk, InStrRev( Laufwerk, "\" ) + 1 )
End If
DirTmp = LogDatei & "_" & Tst & "_.tmp"
LogDatei = LogDatei & "_" & Tst & "_.log"
' MsgBox "LogDatei " & vbTab & LogDatei & vbCRLF & "DirTmp " & vbTab & DirTmp, , "064 :: " : WScript.Quit
Trace32Log "067 :: ++++ " & LaufWerk & " +++++++++++++++", 1
Trace32Log "068 :: DirTmp: '" & DirTmp & "'", 1
Zeit = Timer()
' Prüfen, ob in die DIR-Zieldatei noch geschrieben wird
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists( DirTmp )Then
Text = fso.GetFile( DirTmp ).Size
wshshell.Popup "Bitte nicht OK drücken!!!" , 3, "076 :: Nach 3sek bin ich weg!", vbExclamation
If not Text = fso.GetFile( DirTmp ).Size Then
MsgBox "Z.Z. wird Laufwerk " & vbCRLF & vbCRLF & LaufWerk & vbCRLF & vbCRLF & " noch geprüft . . .", 4096 + vbInformation, "078 :: " & WScript.ScriptName
WScript.Quit
Else
Text = "Laufwerk " & LaufWerk & " wurde bereits geprüft. "
Text = Text & "Soll eine neue DIR-Datei erstellt werden?"
i = MsgBox (Text, 3+32+256+4096, "083 :: " & WScript.ScriptName)
If i = vbCancel Then WScript.Quit
End If
End If
' MaxAnz festlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = "Dateien mit kompletten Pfad dürfen eine bestimmte Zeichenanzahl nicht übersteigen." & vbCRLF & vbCRLF
Text = Text & "Es sollen alle Dateien mit komplettem Pfad aufgelistet werden, deren Zeichenanzahl folgende Zahl übersteigt:"
MaxAnz = InputBox (Text, WScript.ScriptName, MaxAnz)
If MaxAnz = "" Then MsgBox " . . . denn eben nicht!", , "093 :: " & WScript.ScriptName
If MaxAnz = "" Then WScript.Quit
MaxAnz = CInt(MaxAnz)
If Len( LaufWerk ) = 3 AND InStr( LaufWerk, ":\" ) = 2 Then
LaufWerk = Left( LaufWerk, 2 )
End If
Trace32Log "101 :: ++++ " & LaufWerk & " +++++++++++++++", 1
Trace32Log "102 :: Start " & now(), 1
Zeit = Timer()
' Neue DIR-Zieldatei wird erstellt
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = "%comspec% /c dir """ & LaufWerk & "\"" /s /b > """ & DirTmp & """"
' MsgBox Text, , "108 :: "
WSHShell.run Text, 0, True
Trace32Log "110 :: DIR-End - Dauer: " & Timer() - Zeit & "s", 1
' Neue DIR-Zieldatei zum Lesen öffnen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if not fso.FileExists( DirTmp) Then wshshell.Popup "Bitte nicht OK drücken!!!", 3, "114 :: Nach 3sek bin ich weg!", vbExclamation
' WSHShell.run "notepad """ & DirTmp & """", , True
' Neue DIR-Zieldatei zeilenweise lesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set fi = FSO.OpenTextFile( DirTmp, 1 ) ' Datei zum Lesen öffnen
Do While Not (fi.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
iDatei = iDatei +1
Text = fi.Readline
If Len(Text) > MaxAnz Then ' Zeilenlänge zu gross?
iLang = iLang +1
Trace32Log "127 :: Nr.: " & iLang & " Länge: " & len(Text) & " " & Text, 1 ' protokollieren
End If
Loop
fi.Close
Set fi = Nothing ' Datei schließen
' Text = iDatei & " Dateien auf Laufwerk " & LaufWerk & " wurden überprüft."
Trace32Log "134 :: " & iLang & " " & "Dateien haben mehr als " & MaxAnz & " Zeichen im Dateinamen . . .", 1
Trace32Log "135 :: " & iDatei & " " & "Dateien/Verzeichnissen auf Laufwerk " & LaufWerk & " wurden geprüft.", 1
Trace32Log "136 :: " & "Dauer: " & Timer() - Zeit & "s", 1
' Zeit = hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & secound(Zeit-now())
Trace32Log "140 :: Ende " & now() & " - Dauer: " & Timer() - Zeit & "s", 1
Trace32Log "142 :: ++++ " & LaufWerk & " +++++++++++++++", 1
WSHShell.run """" & LogDatei & """", , False
WScript.Sleep 1500
WSHShell.Sendkeys "^{End}"
WScript.Quit
'***********************************************************
Function ToANSI( ASCIIz )
'***********************************************************
' von Christoph Basedau aus
' http://groups.google.de/groups?q=ToANSI+%3D+Replace&hl=de&lr=&newwindow=1&selm=ugGVQok3AHA.1604%40tkmsftngp02&rnum=1
ToANSI = Replace(ASCIIz, chr(132), chr(228))
ToANSI = Replace(ToANSI, chr(129), chr(252))
ToANSI = Replace(ToANSI, chr(142), Chr(196))
ToANSI = Replace(ToANSI, chr(154), Chr(220))
ToANSI = Replace(ToANSI, chr(153), Chr(214))
ToANSI = Replace(ToANSI, chr(148), Chr(246))
ToANSI = Replace(ToANSI, chr(225), Chr(223))
End Function ' ToANSI( ASCIIz )
'*** v9.4 *** www.dieseyer.de ******************************
Function BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'***********************************************************
' http://www.codecomments.com/message367170.html
' http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_frm/thread/f083a8d1806e9a68/d835b2a1ec45afec?lnk=st&q=BrowseForFolder+strPrompt+intBrowseInfo+vRootFolder&rnum=1&hl=de#d835b2a1ec45afec
'
'BrowseForFolder dialog. Follows MSDN example closely. Also handles selection of special
'folders (ex Desktop), which do not return a folder3 object as 'normal' folders do.
'Code below does not support all options, only folders.
'To use, copy and paste function into script,
'call as BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder) where root folder is either an
'integer (constants below) or a string with a folder path.
'To use the constants below, they must be in the script header.
'Flags specifying the options for the dialog box. This member can include zero or a combination of the following values.
Const BIF_BROWSEFORCOMPUTER = 4096 'Only return computers. If the user selects anything other than a computer, the OK button is grayed.
Const BIF_BROWSEFORPRINTER = 8192 'Only allow the selection of printers. If the user selects anything other than a printer, the OK button is grayed. In Microsoft Windows XP, the best practice is to use an XP-style dialog, setting the root of the dialog to the Printers and Faxes folder (CSIDL_PRINTERS).
Const BIF_BROWSEINCLUDEFILES = 16384 'Version 4.71. The browse dialog box will display files as well as folders.
'Const BIF_BROWSEINCLUDEURLS = 'Version 5.0. The browse dialog box can display URLs. The BIF_USENEWUI and BIF_BROWSEINCLUDEFILES flags must also be set. If these three flags are not set, the browser dialog box will reject URLs. Even when these flags are set, the browse dialog box will only display URLs if the folder that contains the selected item supports them. When the folder's IShellFolder::GetAttributesOf method is called to request the selected item's attributes, the folder must set the SFGAO_FOLDER attribute flag. Otherwise, the browse dialog box will not display the URL.
Const BIF_DONTGOBELOWDOMAIN = 2 'Do not include network folders below the domain level in the dialog box's tree view control.
Const BIF_EDITBOX = 16 'Version 4.71. Include an edit control in the browse dialog box that allows the user to type the name of an item.
'Const BIF_NEWDIALOGSTYLE = 'Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_NONEWFOLDERBUTTON = 512 'Version 6.0. Do not include the New Folder button in the browse dialog box.
'Const BIF_NOTRANSLATETARGETS = 'Version 6.0. When the selected item is a shortcut, return the PIDL of the shortcut itself rather than its target.
Const BIF_RETURNFSANCESTORS = 8 'Only return file system ancestors. An ancestor is a subfolder that is beneath the root folder in the namespace hierarchy. If the user selects an ancestor of the root folder that is not part of the file system, the OK button is grayed. Const BIF_RETURNONLYFSDIRS = 1 'Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
'Const BIF_SHAREABLE = 'Version 5.0. The browse dialog box can display shareable resources on remote systems. It is intended for applications that want to expose remote shares on a local system. The BIF_NEWDIALOGSTYLE flag must also be set.
Const BIF_STATUSTEXT = 4 'Include a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. This flag is not supported when BIF_NEWDIALOGSTYLE is specified.
'Const BIF_UAHINT = 'Version 6.0. When combined with BIF_NEWDIALOGSTYLE, adds a usage hint to the dialog box in place of the edit box. BIF_EDITBOX overrides this flag.
'Const BIF_USENEWUI = 'Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE. To use BIF_USENEWUI, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_VALIDATE = 32 'Version 4.71. If the user types an invalid name into the edit box, the browse dialog box will call the application's BrowseCallbackProc with the BFFM_VALIDATEFAILED message. This flag is ignored if BIF_EDITBOX is not specified.
Const ssfALTSTARTUP = 29 'File system directory that corresponds to the user's nonlocalized Startup program group. (value = 29)
Const ssfAPPDATA = 26 'Version 4.71. File system directory that serves as a common repository for application-specific data. A typical path is C:\Documents and Settings\username\Application Data. (value = 26)
Const ssfBITBUCKET = 10 'Virtual folder containing the objects in the user's Recycle Bin. (value = 15)
Const ssfCOMMONALTSTARTUP = 30 'File system directory that corresponds to the nonlocalized Startup program group for all users. Valid only for Microsoft Windows NT systems. (value = 30)
Const ssfCOMMONAPPDATA = 35 'Version 5.0. Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data. (value = 35)
Const ssfCOMMONDESKTOPDIR = 25 'File system directory that contains files and folders that appear on the desktop for all users. A typical path is C:\Documents and Settings\All Users\Desktop. Valid only for Windows NT systems. (value = 25)
Const ssfCOMMONFAVORITES = 31 'File system directory that serves as a common repository for all users' favorite items. Valid only for Windows NT systems. (value = 31)
Const ssfCOMMONPROGRAMS = 23 'File system directory that contains the directories for the common program groups that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs. Valid only for Windows NT systems. (value = 23)
Const ssfCOMMONSTARTMENU = 22 'File system directory that contains the programs and folders that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu. Valid only for Windows NT systems. (value = 22)
Const ssfCOMMONSTARTUP = 24 'File system directory that contains the programs that appear in the Startup folder for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs\Startup. Valid only for Windows NT systems. (value = 24)
Const ssfCONTROLS = 3 'Virtual folder containing icons for the Control Panel applications. (value = 3)
Const ssfCOOKIES = 33 'File system directory that serves as a common repository for Internet cookies. A typical path is C:\Documents and Settings\username\Cookies. (value = 33)
Const ssfDESKTOP = 0 'Microsoft Windows Desktop—virtual folder that is the root of the namespace. (value = 0)
Const ssfDESKTOPDIRECTORY = 16 'File system directory used to physically store the file objects that are displayed on the desktop. It is not to be confused with the desktop folder itself, which is a virtual folder. A typical path is C:\Documents and Settings\username\Desktop. (value = 16)
Const ssfDRIVES = 17 'My Computer—virtual folder containing everything on the local computer: storage devices, printers, and Control Panel. This folder may also contain mapped network drives. (value = 17)
Const ssfFAVORITES = 6 'File system directory that serves as a common repository for the user's favorite items. A typical path is C:\Documents and Settings\username\Favorites. (value = 6)
Const ssfFONTS = 20 'Virtual folder containing installed fonts. A typical path is C:\WINNT\Fonts. (value = 20)
Const ssfHISTORY = 34 'File system directory that serves as a common repository for Internet history items. (value = 34)
Const ssfINTERNETCACHE = 32 'File system directory that serves as a common repository for temporary Internet files. A typical path is C:\Documents and Settings\username\Temporary Internet Files. (value = 32)
Const ssfLOCALAPPDATA = 28 'Version 5.0. File system directory that serves as a data repository for local (non-roaming) applications. A typical path is C:\Documents and Settings\username\Local Settings\Application Data. (value = 28)
Const ssfMYPICTURES = 39 'My Pictures folder. A typical path is C:\Documents and Settings\username\My Documents\My Pictures. (value = 39)
Const ssfNETHOOD = 19 'A file system folder containing the link objects that may exist in the My Network Places virtual folder. It is not the same as ssfNETWORK, which represents the network namespace root. A typical path is C:\Documents and Settings\username\NetHood. (value = 19)
Const ssfNETWORK = 21 'Network Neighborhood—virtual folder representing the root of the network namespace hierarchy. (value = 18)
Const ssfPERSONAL = 5 'File system directory that serves as a common repository for a user's documents. A typical path is C:\Documents and Settings\username\My Documents. (value = 5)
Const ssfPRINTERS = 4 'Virtual folder containing installed printers. (value = 4)
Const ssfPRINTHOOD = 18 'File system directory that contains the link objects that may exist in the Printers virtual folder. A typical path is C:\Documents and Settings\username\PrintHood. (value = 27)
Const ssfPROFILE = 40 'Version 5.0. User's profile folder. (value = 40)
Const ssfPROGRAMFILES = 38 'Version 5.0. Program Files folder. A typical path is C:\Program Files. (value = 38)
Const ssfPROGRAMS = 2 'File system directory that contains the user's program groups (which are also file system directories). A typical path is C:\Documents and Settings\username\Start Menu\Programs. (value = 2)
Const ssfRECENT = 8 'File system directory that contains the user's most recently used documents. A typical path is C:\Documents and Settings\username\Recent. (value = 8)
Const ssfSENDTO = 9 'File system directory that contains Send To menu items. A typical path is C:\Documents and Settings\username\SendTo. (value = 9)
Const ssfSTARTMENU = 11 'File system directory containing Start menu items. A typical path is C:\Documents and Settings\username\Start Menu. (value = 11)
Const ssfSTARTUP = 7 'File system directory that corresponds to the user's Startup program group. The system starts these programs whenever any user logs onto Windows NT or starts Windows 95. A typical path is C:\Documents and Settings\username\Start Menu\Programs\Startup. (value = 7)
Const ssfSYSTEM = 37 'Version 5.0. System folder. A typical path is C:\WINNT\SYSTEM32. (value = 37)
Const ssfTEMPLATES = 21 'File system directory that serves as a common repository for document templates. (value = 21)
Const ssfWINDOWS = 36 'Version 5.0. Windows directory or SYSROOT. This corresponds to the %windir% or %SYSTEMROOT% environment variables. A typical path is C:\WINNT. (value = 36)
Dim oShell
Dim oFolder
Dim oFolderItem
Dim strPath
Dim oWSHShell
Dim oFSO
Dim bSuccess
Dim errTst
Set oShell = CreateObject("Shell.Application")
Set oWSHShell = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
'syntax: oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [,vRootFolder])
Set oFolder = oShell.BrowseForFolder(&H0, strPrompt, intBrowseInfo, vRootFolder)
On Error Resume Next
'This seems to get a 'normal' folder object from the folder3 object returned by BrowseForFolder
Set oFolderItem = oFolder.Items.Item
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
' MsgBox "Invalid selection; Please try again", , "255 :: " & WScript.ScriptName
Else
'If a special folder (ex. desktop) is selected, object is nothing.
If (oFolderItem Is Nothing) Then
'This is necessary - seems to convert invalid object reference to a string?
strPath = oFolder
Set oFolderItem = oFSO.GetFolder(oWSHShell.SpecialFolders(strPath))
End If
End If
On Error Resume Next
If Not oFSO.FolderExists(oFolderItem.Path) Then
On Error GoTo 0
MsgBox "Invalid selection; Please try again", , "270 :: " & WScript.ScriptName
Else
bSuccess = True
End If
Loop While Not bSuccess
BrowseForFolder = oFolderItem.Path
End Function ' BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "365 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "366 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> dateinamenlangdir2.vbs <<<
'v5.5*****************************************************
' File: DateiNamenLangDIR2.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverzeichnis nach Dateien, deren Name inkl.
' kompletter Pfadangabe länger als 200 Zeichen ist.
' Das Skript prüft, ob es bereist läuft.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Text, i, iDatei, iVerz, iLang, iAnz, MaxAnz, LaufWerk, Modus1, Modus2, Zeit, TmpTmp
Dim WSHShell, fso, fo, fi
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
iLang = 0
Modus1 = 0
Modus2 = 0
LaufWerk = "c:"
LaufWerk = "\\pc-amd\dateien$"
MaxAnz = 200
Text = Text & "Welcher Laufwerkspfad soll auf zu lange Dateiennamen (>"
Text = Text & MaxAnz & " Zeichen) getestet werden?"
' Laufwerkauswahl
' ----------------------
LaufWerk = InputBox (Text, WScript.ScriptName, LaufWerk)
If LaufWerk = "" then MsgBox " . . . denn eben nicht!", , WScript.ScriptName
If LaufWerk = "" then WScript.Quit
LaufWerk = UCase(LaufWerk)
' LaufWerk bereit?
' -------------------------------------------------
On Error Resume Next
LaufWerk = fso.GetDrive(LaufWerk).Path
Text = Err.Description
On Error GoTo 0
if not Text = "" then
Text = "Für " & LaufWerk & " gilt:" & vbCRLF & vbCRLF & Text & " !"
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now() & vbCRLF & "Nr." & vbTab & "Länge" & vbTab & "DateiName"
Zeit = now()
TmpTmp = WScript.ScriptName & ".dir"
' Prüfen, ob in die DIR-Zieldatei noch geschrieben wird
' -------------------------------------------------
if fso.FileExists( TmpTmp )Then
Text = fso.GetFile( TmpTmp ).Size
wshshell.Popup "Bitte nicht OK drücken!!!" , 3, " Nach 3sek bin ich weg!", vbExclamation
if not Text = fso.GetFile( TmpTmp ).Size Then
MsgBox "Dieses Skript läuft z.Z. noch (mit einer Prüfung).", , WScript.ScriptName
WScript.Quit
End If
End If
' MaxAnz festlegen
' -------------------------------------------------
Text = "Dateien mit kompletten Pfad dürfen eine bestimmte Zeichenanzahl nicht übersteigen." & vbCRLF & vbCRLF
Text = Text & "Es sollen alle Dateien mit komplettem Pfad aufgelistet werden, deren Zeichenanzahl folgende Zahl übersteigt:"
MaxAnz = InputBox (Text, WScript.ScriptName, MaxAnz)
If MaxAnz = "" then MsgBox " . . . denn eben nicht!", , WScript.ScriptName
If MaxAnz = "" then WScript.Quit
MaxAnz = CInt(MaxAnz)
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now()
Zeit = now()
' Neue DIR-Zieldatei wird erstellt
' -------------------------------------------------
Text = "%comspec% /c dir " & LaufWerk & "\ /s /b > " & TmpTmp
WSHShell.run Text, 0, True
LogDatei "DIR-End" & vbTab & vbTab & "Dauer" & vbTab & hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & second(Zeit-now())
LogDatei "Nr." & vbTab & "Länge" & vbTab & "DateiName"
' Neue DIR-Zieldatei zum Lesen öffnen
' -------------------------------------------------
if not fso.FileExists( TmpTmp) Then wshshell.Popup "Bitte nicht OK drücken!!!" , 3, " Nach 3sek bin ich weg!", vbExclamation
' Neue DIR-Zieldatei zeilenweise lesen
' -------------------------------------------------
Set fi = FSO.OpenTextFile( TmpTmp, 1 ) ' Datei zum Lesen öffnen
Do While Not (fi.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
iDatei = iDatei +1
Text = fi.Readline
If Len(Text) > MaxAnz Then ' Zeilenlänge zu gross?
iLang = iLang +1
LogDatei iLang & vbTab & len(Text) & vbTab & Text ' protokollieren
End If
Loop
fi.Close
Set fi = Nothing ' Datei schließen
' Text = iDatei & " Dateien auf Laufwerk " & LaufWerk & " wurden überprüft."
Text = iLang & vbTab & "Dateien hatten mehr als " & MaxAnz & " Zeichen." & vbCRLF
Text = Text & iDatei & vbTab & "Dateien/Verzeichnissen auf Laufwerk " & LaufWerk & " wurden überprüft."
' Zeit = hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & secound(Zeit-now())
LogDatei "Nr." & vbTab & "Länge" & vbTab & "DateiName" & vbCRLF & Text
LogDatei "Ende" & vbTab & now() & vbTab & "Dauer" & vbTab & hour(Zeit-now()) & ":" & minute(Zeit-now()) & ":" & second(Zeit-now())
MsgBox Text, , WSCript.ScriptName
LogDatei "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF
WScript.Sleep( 666 )
WSHShell.run "notepad " & WScript.ScriptName & ".log"
WScript.Sleep( 666 )
WSHShell.Sendkeys "^{End}"
WScript.Quit
'*********************************************************
Function ToANSI( ASCIIz )
'*********************************************************
' von Christoph Basedau aus
' http://groups.google.de/groups?q=ToANSI+%3D+Replace&hl=de&lr=&newwindow=1&selm=ugGVQok3AHA.1604%40tkmsftngp02&rnum=1
ToANSI = Replace(ASCIIz, chr(132), chr(228))
ToANSI = Replace(ToANSI, chr(129), chr(252))
ToANSI = Replace(ToANSI, chr(142), Chr(196))
ToANSI = Replace(ToANSI, chr(154), Chr(220))
ToANSI = Replace(ToANSI, chr(153), Chr(214))
ToANSI = Replace(ToANSI, chr(148), Chr(246))
ToANSI = Replace(ToANSI, chr(225), Chr(223))
End Function ' ToANSI( ASCIIz )
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & ".log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> dateinamenlangvbs.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' File: DateiNamenLangVBS.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverzeichnis nach Dateien, deren Name inkl.
' kompletter Pfadangabe länger als 250 Zeichen ist.
' Seit v9.4 mit 'Browse For Folder', wenn die Variable
' "LaufWerk" leer ist.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim TmpTmp, Text, i, iDatei, iVerz, iLang, iAnz, MaxAnz, LaufWerk, Modus1, Modus2, Zeit
Dim WSHShell, fso, fi
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
iLang = 0
Modus1 = 0 ' bei =1 werden kein ZwichenMeldungen ausgegeben
Modus2 = 0 ' bei =1 werden kein ZwichenMeldungen ausgegeben
MaxAnz = 200
LaufWerk = "d:\"
LaufWerk = ""
If LaufWerk = "" Then LaufWerk = BrowseForFolder( "Verzeichnis auswählen:", 9+16384, 0 )
Text = Text & "Welches Laufwerk soll auf zu lange Dateiennamen (>"
Text = Text & MaxAnz & " Zeichen) getestet werden?"
' Pfad erreichbar?
' -------------------------------------------------
If fso.FolderExists( Laufwerk ) Then
Else
Text = "Für " & LaufWerk & " gilt:" & vbCRLF & vbCRLF & Text & " !"
MsgBox vbTab & "= = = F E H L E R = = =" & Laufwerk & vbCRLF & vbCRLF & "ist nicht erreichbar!", , "039 :: " & WScript.ScriptName
WScript.Quit
End If
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now() & vbCRLF & "Nr." & vbTab & "Länge" & vbTab & "DateiName"
Zeit = now()
TmpTmp = WScript.ScriptName & "_" & fso.GetBaseName( LaufWerk ) & "_" & ".tmp"
' Prüfen, ob in die Zieldatei noch geschrieben wird
' -------------------------------------------------
if fso.FileExists( TmpTmp )Then
Text = fso.GetFile( TmpTmp ).Size
wshshell.Popup "Bitte nicht OK drücken!!!" , 3, "Nach 3sek bin ich weg!", vbExclamation, "052 :: " & WScript.ScriptName
if not Text = fso.GetFile( TmpTmp ).Size Then
MsgBox "Z.Z. wird Laufwerk " & LaufWerk & " noch geprüft.", , "054 :: " & WScript.ScriptName
WScript.Quit
Else
Text = "Laufwerk " & LaufWerk & " wurde bereits geprüft. "
Text = Text & "Soll eine neue Liste erstellt werden?"
i = MsgBox( Text, 3+32+256, , "059 :: " & WScript.ScriptName )
If i = vbCancel then WScript.Quit
End If
End If
' MaxAnz festlegen
' -------------------------------------------------
Text = "Dateien mit kompletten Pfad dürfen eine bestimmte Zeichenanzahl nicht übersteigen." & vbCRLF & vbCRLF
Text = Text & "Es sollen alle Dateien mit komplettem Pfad aufgelistet werden, deren Zeichenanzahl folgende Zahl übersteigt:"
MaxAnz = InputBox (Text, WScript.ScriptName, MaxAnz)
If MaxAnz = "" then MsgBox " . . . denn eben nicht!", , "069 :: " & WScript.ScriptName
If MaxAnz = "" then WScript.Quit
MaxAnz = CInt(MaxAnz)
LogDatei vbCRLF & "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF & "Start" & vbTab & now()
Zeit = Timer()
' MsgBox LaufWerk, , "075 :: " & WScript.ScriptName
RecFolder 0, LaufWerk
Text = iLang & vbTab & "Dateien hatten mehr als " & MaxAnz & " Zeichen." & vbCRLF
Text = Text & iDatei & vbTab & "Dateien in " & iVerz & " Verzeichnissen auf Laufwerk " & LaufWerk & " wurden überprüft." & vbCRLF
Text = Text & vbTab & "Dauer: " & Timer() - Zeit & "s"
LogDatei "Nr." & vbTab & "Länge" & vbTab & "DateiName" & vbCRLF & Text
LogDatei "Stop " & now() & " - Dauer: " & Timer() - Zeit & "s"
MsgBox Text, , "085 :: " & WScript.ScriptName
LogDatei "++++ " & LaufWerk & " +++++++++++++++" & vbCRLF
WSHShell.run "notepad.exe """ & WScript.ScriptName & ".log"""
WScript.Sleep 1500
WSHShell.Sendkeys "^{End}"
WScript.Quit
' Autor: (c) Günter Born
'***********************************************************
Sub RecFolder (idx, path)
' Rekursive Ordnerbearbeitung (hole Unterordner)
Dim oFolders, oSubFolder, oFolder
' Hole Folders-Auflistung
' MsgBox path & vbCRLF & "i: " & i, , "101 :: " & WScript.ScriptName
Set oFolders = fso.GetFolder(path)
Set Fi = oFolders.Files ' Datei-Listung holen
For Each i In Fi ' hole alle Dateien aus Datei-Liste
iDatei = iDatei +1
iAnz = iAnz +1
' If iAnz >= 100 AND Modus2 < 1 Then Modus2 = WSHShell.Popup (iDatei & " Dateien wurden geprüft . . . " & VBCRLF & VBCRLF & "Weiterhin Anzahl der geprüften Dateien anzeigen?", 1, "108 :: " & WScript.Scriptname, 1)
if iAnz >= 100 then iAnz = 0
' if iDatei > 2000 then WScript.Quit
Text = path & "\" & oFolders.name & "\" & i.Name
if len(Text) > MaxAnz then
iLang = iLang +1
Text = iLang & vbTab & len(Text) & vbTab & Text
LogDatei Text
If Modus1 < 1 Then Modus1 = WSHShell.Popup (Text & VBCRLF & VBCRLF & "Weiterhin jede zu lange Datei anzeigen?", 1, "116 :: " & WScript.Scriptname, 1)
End If
Next
'' Fi.Close
Set Fi = Nothing ' Datei schließen
Set oSubFolder = oFolders.SubFolders
Redim Preserve Txt(idx) ' redim String-Array
For Each oFolder in oSubFolder ' alle Ordner
iVerz = iVerz +1
' WSHShell.Popup oFolder & " wird geprüft . . . ", 1, "126 :: " & WScript.Scriptname
Txt(idx) = Txt(idx) & path & "\" & oFolder.name & vbCRLF
' Unterordner rekursiv suchen
Call RecFolder (idx+1, path & "\" & oFolder.name)
Next
Set oFolders = Nothing ' Variable freigeben
Set oSubFolder = Nothing
End Sub ' RecFolder (idx, path)
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
'*** v9.4 *** www.dieseyer.de ******************************
Function BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
'***********************************************************
' http://www.codecomments.com/message367170.html
' http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_frm/thread/f083a8d1806e9a68/d835b2a1ec45afec?lnk=st&q=BrowseForFolder+strPrompt+intBrowseInfo+vRootFolder&rnum=1&hl=de#d835b2a1ec45afec
'
'BrowseForFolder dialog. Follows MSDN example closely. Also handles selection of special
'folders (ex Desktop), which do not return a folder3 object as 'normal' folders do.
'Code below does not support all options, only folders.
'To use, copy and paste function into script,
'call as BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder) where root folder is either an
'integer (constants below) or a string with a folder path.
'To use the constants below, they must be in the script header.
'Flags specifying the options for the dialog box. This member can include zero or a combination of the following values.
Const BIF_BROWSEFORCOMPUTER = 4096 'Only return computers. If the user selects anything other than a computer, the OK button is grayed.
Const BIF_BROWSEFORPRINTER = 8192 'Only allow the selection of printers. If the user selects anything other than a printer, the OK button is grayed. In Microsoft Windows XP, the best practice is to use an XP-style dialog, setting the root of the dialog to the Printers and Faxes folder (CSIDL_PRINTERS).
Const BIF_BROWSEINCLUDEFILES = 16384 'Version 4.71. The browse dialog box will display files as well as folders.
'Const BIF_BROWSEINCLUDEURLS = 'Version 5.0. The browse dialog box can display URLs. The BIF_USENEWUI and BIF_BROWSEINCLUDEFILES flags must also be set. If these three flags are not set, the browser dialog box will reject URLs. Even when these flags are set, the browse dialog box will only display URLs if the folder that contains the selected item supports them. When the folder's IShellFolder::GetAttributesOf method is called to request the selected item's attributes, the folder must set the SFGAO_FOLDER attribute flag. Otherwise, the browse dialog box will not display the URL.
Const BIF_DONTGOBELOWDOMAIN = 2 'Do not include network folders below the domain level in the dialog box's tree view control.
Const BIF_EDITBOX = 16 'Version 4.71. Include an edit control in the browse dialog box that allows the user to type the name of an item.
'Const BIF_NEWDIALOGSTYLE = 'Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands. To use this flag, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_NONEWFOLDERBUTTON = 512 'Version 6.0. Do not include the New Folder button in the browse dialog box.
'Const BIF_NOTRANSLATETARGETS = 'Version 6.0. When the selected item is a shortcut, return the PIDL of the shortcut itself rather than its target.
Const BIF_RETURNFSANCESTORS = 8 'Only return file system ancestors. An ancestor is a subfolder that is beneath the root folder in the namespace hierarchy. If the user selects an ancestor of the root folder that is not part of the file system, the OK button is grayed. Const BIF_RETURNONLYFSDIRS = 1 'Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
'Const BIF_SHAREABLE = 'Version 5.0. The browse dialog box can display shareable resources on remote systems. It is intended for applications that want to expose remote shares on a local system. The BIF_NEWDIALOGSTYLE flag must also be set.
Const BIF_STATUSTEXT = 4 'Include a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. This flag is not supported when BIF_NEWDIALOGSTYLE is specified.
'Const BIF_UAHINT = 'Version 6.0. When combined with BIF_NEWDIALOGSTYLE, adds a usage hint to the dialog box in place of the edit box. BIF_EDITBOX overrides this flag.
'Const BIF_USENEWUI = 'Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE. To use BIF_USENEWUI, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.
Const BIF_VALIDATE = 32 'Version 4.71. If the user types an invalid name into the edit box, the browse dialog box will call the application's BrowseCallbackProc with the BFFM_VALIDATEFAILED message. This flag is ignored if BIF_EDITBOX is not specified.
Const ssfALTSTARTUP = 29 'File system directory that corresponds to the user's nonlocalized Startup program group. (value = 29)
Const ssfAPPDATA = 26 'Version 4.71. File system directory that serves as a common repository for application-specific data. A typical path is C:\Documents and Settings\username\Application Data. (value = 26)
Const ssfBITBUCKET = 10 'Virtual folder containing the objects in the user's Recycle Bin. (value = 15)
Const ssfCOMMONALTSTARTUP = 30 'File system directory that corresponds to the nonlocalized Startup program group for all users. Valid only for Microsoft Windows NT systems. (value = 30)
Const ssfCOMMONAPPDATA = 35 'Version 5.0. Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data. (value = 35)
Const ssfCOMMONDESKTOPDIR = 25 'File system directory that contains files and folders that appear on the desktop for all users. A typical path is C:\Documents and Settings\All Users\Desktop. Valid only for Windows NT systems. (value = 25)
Const ssfCOMMONFAVORITES = 31 'File system directory that serves as a common repository for all users' favorite items. Valid only for Windows NT systems. (value = 31)
Const ssfCOMMONPROGRAMS = 23 'File system directory that contains the directories for the common program groups that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs. Valid only for Windows NT systems. (value = 23)
Const ssfCOMMONSTARTMENU = 22 'File system directory that contains the programs and folders that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu. Valid only for Windows NT systems. (value = 22)
Const ssfCOMMONSTARTUP = 24 'File system directory that contains the programs that appear in the Startup folder for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs\Startup. Valid only for Windows NT systems. (value = 24)
Const ssfCONTROLS = 3 'Virtual folder containing icons for the Control Panel applications. (value = 3)
Const ssfCOOKIES = 33 'File system directory that serves as a common repository for Internet cookies. A typical path is C:\Documents and Settings\username\Cookies. (value = 33)
Const ssfDESKTOP = 0 'Microsoft Windows Desktop—virtual folder that is the root of the namespace. (value = 0)
Const ssfDESKTOPDIRECTORY = 16 'File system directory used to physically store the file objects that are displayed on the desktop. It is not to be confused with the desktop folder itself, which is a virtual folder. A typical path is C:\Documents and Settings\username\Desktop. (value = 16)
Const ssfDRIVES = 17 'My Computer—virtual folder containing everything on the local computer: storage devices, printers, and Control Panel. This folder may also contain mapped network drives. (value = 17)
Const ssfFAVORITES = 6 'File system directory that serves as a common repository for the user's favorite items. A typical path is C:\Documents and Settings\username\Favorites. (value = 6)
Const ssfFONTS = 20 'Virtual folder containing installed fonts. A typical path is C:\WINNT\Fonts. (value = 20)
Const ssfHISTORY = 34 'File system directory that serves as a common repository for Internet history items. (value = 34)
Const ssfINTERNETCACHE = 32 'File system directory that serves as a common repository for temporary Internet files. A typical path is C:\Documents and Settings\username\Temporary Internet Files. (value = 32)
Const ssfLOCALAPPDATA = 28 'Version 5.0. File system directory that serves as a data repository for local (non-roaming) applications. A typical path is C:\Documents and Settings\username\Local Settings\Application Data. (value = 28)
Const ssfMYPICTURES = 39 'My Pictures folder. A typical path is C:\Documents and Settings\username\My Documents\My Pictures. (value = 39)
Const ssfNETHOOD = 19 'A file system folder containing the link objects that may exist in the My Network Places virtual folder. It is not the same as ssfNETWORK, which represents the network namespace root. A typical path is C:\Documents and Settings\username\NetHood. (value = 19)
Const ssfNETWORK = 21 'Network Neighborhood—virtual folder representing the root of the network namespace hierarchy. (value = 18)
Const ssfPERSONAL = 5 'File system directory that serves as a common repository for a user's documents. A typical path is C:\Documents and Settings\username\My Documents. (value = 5)
Const ssfPRINTERS = 4 'Virtual folder containing installed printers. (value = 4)
Const ssfPRINTHOOD = 18 'File system directory that contains the link objects that may exist in the Printers virtual folder. A typical path is C:\Documents and Settings\username\PrintHood. (value = 27)
Const ssfPROFILE = 40 'Version 5.0. User's profile folder. (value = 40)
Const ssfPROGRAMFILES = 38 'Version 5.0. Program Files folder. A typical path is C:\Program Files. (value = 38)
Const ssfPROGRAMS = 2 'File system directory that contains the user's program groups (which are also file system directories). A typical path is C:\Documents and Settings\username\Start Menu\Programs. (value = 2)
Const ssfRECENT = 8 'File system directory that contains the user's most recently used documents. A typical path is C:\Documents and Settings\username\Recent. (value = 8)
Const ssfSENDTO = 9 'File system directory that contains Send To menu items. A typical path is C:\Documents and Settings\username\SendTo. (value = 9)
Const ssfSTARTMENU = 11 'File system directory containing Start menu items. A typical path is C:\Documents and Settings\username\Start Menu. (value = 11)
Const ssfSTARTUP = 7 'File system directory that corresponds to the user's Startup program group. The system starts these programs whenever any user logs onto Windows NT or starts Windows 95. A typical path is C:\Documents and Settings\username\Start Menu\Programs\Startup. (value = 7)
Const ssfSYSTEM = 37 'Version 5.0. System folder. A typical path is C:\WINNT\SYSTEM32. (value = 37)
Const ssfTEMPLATES = 21 'File system directory that serves as a common repository for document templates. (value = 21)
Const ssfWINDOWS = 36 'Version 5.0. Windows directory or SYSROOT. This corresponds to the %windir% or %SYSTEMROOT% environment variables. A typical path is C:\WINNT. (value = 36)
Dim oShell
Dim oFolder
Dim oFolderItem
Dim strPath
Dim oWSHShell
Dim oFSO
Dim bSuccess
Dim errTst
Set oShell = CreateObject("Shell.Application")
Set oWSHShell = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
'syntax: oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [,vRootFolder])
Set oFolder = oShell.BrowseForFolder(&H0, strPrompt, intBrowseInfo, vRootFolder)
On Error Resume Next
'This seems to get a 'normal' folder object from the folder3 object returned by BrowseForFolder
Set oFolderItem = oFolder.Items.Item
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
' MsgBox "Invalid selection; Please try again", , "242 :: " & WScript.ScriptName
Else
'If a special folder (ex. desktop) is selected, object is nothing.
If (oFolderItem Is Nothing) Then
'This is necessary - seems to convert invalid object reference to a string?
strPath = oFolder
Set oFolderItem = oFSO.GetFolder(oWSHShell.SpecialFolders(strPath))
End If
End If
On Error Resume Next
If Not oFSO.FolderExists(oFolderItem.Path) Then
On Error GoTo 0
MsgBox "Invalid selection; Please try again", , "257 :: " & WScript.ScriptName
Else
bSuccess = True
End If
Loop While Not bSuccess
BrowseForFolder = oFolderItem.Path
End Function ' BrowseForFolder(strPrompt, intBrowseInfo, vRootFolder)
#########################################################################
>>> dateinamespeichern.vbs <<<
'v2.9********************************************************
' File: DateiNameSpeichern.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Mit der Maus eine Datei / Ordner auf das Skript ziehen und
' der komplette Pfad wird in einer Datei gespeichert . . .
' oder man legt das Skript im "Send To"-Ordner ab und kann
' dann mit der rechten Maus-Taste die Info speichern.
'************************************************************
Option Explicit
Dim fso, WSHShell, ZielDatei, oArgs, Datei, FileOut, Text
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
ZielDatei = WScript.ScriptName & ".txt"
ZielDatei = "c:\DateiName.txt"
set oArgs = Wscript.Arguments ' hole Argumentsauflistung
If oArgs.Count > 0 Then ' gibt es Argumente?
Datei = oArgs.item(0) ' erstes Argument
Else
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Maus ein Datei auf das Skript ziehen und" & vbCRLF
Text = Text & "fallen lassen - JETZT werden die Dateiinformationen" & vbCRLF
Text = Text & "in der Datei " & ZielDatei & " gespeichert." & vbCRLF & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
if fso.FileExists(Datei) then
wshshell.Popup fso.GetFile(Datei).Path , 2, WScript.ScriptName, vbExclamation
Set FileOut = fso.OpenTextFile( ZielDatei, 8, true)
fileOut.WriteLine (Datei)
fileOut.Close
Set FileOut = Nothing
End If
if fso.FolderExists(Datei) then
wshshell.Popup Datei , 2, WScript.ScriptName, vbExclamation
Set FileOut = fso.OpenTextFile( ZielDatei, 8, true)
FileOut.WriteLine (Datei)
FileOut.Close
Set FileOut = Nothing
End If
#########################################################################
>>> dateisichernbak.vbs <<<
'*** v8.2 *** www.dieseyer.de *******************************
'
' Datei: dateisichernbak.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Das Problem: Ein Server schreibt eine .LOG-Datei. Sobald
' diese größer als 1 MByte ist, wird sie in. *.bak umbenannt
' und dabei die alte .BAK-Datei überschrieben - das geschieht
' ca. alle zwei Tage. Das Skript prüft nun stündlich das
' Dateidatum (DateLastModified) dieser .BAK-Datei und sobald
' sich dieses ändert, wird eine Kopie 'sicher gestellt'.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim VBSmodTest
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.ComputerName & "-.log"
LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup "= = = S T A R T = = =", 2, "034 :: " & WScript.ScriptName
LogEintrag "035 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "036 :: LogDatei: " & LogDatei
LogEintrag "037 :: PCname: " & WSHNet.ComputerName
LogEintrag "038 :: Angemeldeter User: " & WSHNet.UserName
Const BakDatei1 = "C:\k6logs\sysinfo.bak"
Const BakDatei2 = "C:\k6logs\k6.bak"
Const SicherVerz1 = "C:\INFECTED\1"
Const SicherVerz2 = "C:\INFECTED\2"
Dim Tst
Do
' WScript.Sleep 1000 ' neue Sekunde abwarten
Do ' warten, bis eine neue Minute (mit xx:yy:00) anfängt
WScript.Sleep 20
If InStr( now(), ":00" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":10" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":20" ) = Len( now() ) - 2 Then Exit Do
If InStr( now(), ":30" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":40" ) = Len( now() ) - 2 Then Exit Do
' If InStr( now(), ":50" ) = Len( now() ) - 2 Then Exit Do
Loop
If InStr( now(), ":13:0" ) > 0 Then ' in jeder Stunde zur 13. Minute
Tst = BakDateiSichern( BakDatei1, SicherVerz1 )
If Len( Tst ) > 3 Then
LogEintrag "063 :: Gesichert (" & BakDatei1 & ") nach " & Tst
Else
LogEintrag "065 :: Nicht gesichert: " & BakDatei1
End If
End If
If InStr( now(), ":17:0" ) > 0 Then ' in jeder Stunde zur 17. Minute
Tst = BakDateiSichern( BakDatei2, SicherVerz2 )
If Len( Tst ) > 3 Then
LogEintrag "072 :: Gesichert (" & BakDatei2 & ") nach " & Tst
Else
LogEintrag "074 :: Nicht gesichert: " & BakDatei2
End If
End If
If InStr( now(), "9:0" ) > 0 Then ' alle 10min; 09, 19, 29, 39, 49, 59
Tst = BakDateiSichern( BakDatei2, SicherVerz2 )
If Len( Tst ) > 3 Then LogEintrag "080 :: Gesichert (" & BakDatei2 & ") nach " & Tst
End If
If InStr( now(), "8:0" ) OR InStr( now(), "3:0" ) > 0 Then ' alle 5min; 03, 08, 13, 18, ...
Tst = BakDateiSichern( BakDatei2, SicherVerz2 )
If Len( Tst ) > 3 Then LogEintrag "085 :: Gesichert (" & BakDatei2 & ") nach " & Tst
End If
If InStr( now(), "6:0" ) OR InStr( now(), "1:0" ) > 0 Then ' alle 5min; 01, 06, 11, 16, ...
Tst = BakDateiSichern( BakDatei1, SicherVerz1 )
If Len( Tst ) > 3 Then
LogEintrag "091 :: Gesichert (" & BakDatei1 & ") nach " & Tst
Else
LogEintrag "093 :: Nicht gesichert: " & BakDatei1
End If
End If
' Tst = ""
' Tst = BakDateiSichern( BakDatei2, SicherVerz2 ) ' bei jedem Durchlauf'
' If Len( Tst ) > 3 Then
' LogEintrag "100 :: Gesichert (" & BakDatei2 & ") nach " & Tst
' Else
' LogEintrag "102 :: Nicht gesichert: " & BakDatei2
' End If
VBSmodTest = VBSmodTest + 1 : VBSbeenden() : VBSneustart()
' LogEintrag "106 :: VBSmodTest: " & VBSmodTest
WScript.Sleep 1000 ' neue Sekunde abwarten
Loop
WSHShell.Popup "= = = E N D E = = =", 2, "111 :: " & WScript.ScriptName
LogEintrag "112 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
Wscript.Quit
'*** v8.2 *** www.dieseyer.de *******************************
Function BakDateiSichern( BakDatei, ZielVerz )
'************************************************************
' prüft, ob eine neuere BackDatei als die letzte vorhanden
' existiert - wenn ja, wird die neue gesichert
' On Error Resume Next
' Am Ende von ZielVerz soll ein "\" sein!
If not InStrRev( ZielVerz, "\" ) = Len( ZielVerz ) Then ZielVerz = ZielVerz & "\"
' LogEintrag "127 :: Start: ""Function BakDateiSichern( " & BakDatei & ", " & ZielVerz & " )"" "
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim DateiNr : DateiNr = 0
Dim i
Dim ZielDatei, ZielEndg, DateiDatum
Dim arrDateiLst
Dim NeuereBakDatei : NeuereBakDatei = "JA"
BakDateiSichern = ""
If fso.FileExists( BakDatei ) Then
' LogEintrag "139 :: Zu kopierende BakDatei (QuellDatei) existiert: " & BakDatei
Else
LogEintrag "141 :: Zu kopierende BakDatei (QuellDatei) fehlt: " & BakDatei
LogEintrag "142 :: Exit: ""Function BakDateiSichern( " & BakDatei & ", " & ZielVerz & " )"" "
Exit Function
End If
' LogEintrag "146 :: BakDatei (QuellDatei): " & BakDatei
ZielDatei = ZielVerz & fso.GetBaseName( BakDatei ) & "_" ' ohne Endung
ZielEndg = "." & fso.GetExtensionName( BakDatei )
DateiDatum = fso.GetFile( BakDatei ).DateLastModified
' LogEintrag "150 :: ZielDatei: " & ZielDatei : LogEintrag "150 :: ZielEndg: " & ZielEndg : LogEintrag "150 :: DateiDatum: " & DateiDatum
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrDateiLst = Dateilisteholen( ZielVerz )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' LogEintrag "156 :: UBound( arrDateiLst ): " & UBound( arrDateiLst ) & " - also " & UBound( arrDateiLst ) + 1 & " Dateien."
For i = LBound( arrDateiLst ) to UBound( arrDateiLst )
' letzte vergebene Lfd.Nr. ermitteln und letztes Änderungsdatum im ZielVerz vergleichen
' LogEintrag "161 :: Testen auf richtige ZielDatei: " & arrDateiLst(i)
If InStr( arrDateiLst(i), ZielDatei ) = 1 Then
' LogEintrag "163 :: Richtiger ZielDatei-Name: " & arrDateiLst(i)
If UCase( Mid( arrDateiLst(i), InStrRev( arrDateiLst(i), "." ) ) ) = UCase( ZielEndg ) Then
' bereits gesicherte Datei gefunden
' LogEintrag "166 :: Richtige ZielDatei-Endung: " & arrDateiLst(i)
' Lfd.Nr. herauslösen; wenn größer als die letzte entdeckte, merken
Tst = Replace( UCase( arrDateiLst(i) ), UCase( ZielDatei ), "" )
Tst = Replace( Tst, UCase( ZielEndg ), "" ) : Tst = Int( Tst )
If Tst > DateiNr Then DateiNr = Tst ' letzte Lfd. Nr wird ermittelt
' LogEintrag "172 :: DateiNr: " & DateiNr
' Dateiänderungsdatumvergleichen
If NeuereBakDatei = "JA" AND DateiDatum = fso.GetFile( arrDateiLst(i) ).DateLastModified Then NeuereBakDatei = "-JA"
' LogEintrag "176 :: " & DateiDatum & " =?= " & fso.GetFile( arrDateiLst(i) ).DateLastModified
' LogEintrag "177 :: NeuereBakDatei: " & NeuereBakDatei
End If
End If
Next
If NeuereBakDatei = "JA" Then
' LogEintrag "184 :: (BakDatei) muss gesichert werden: " & BakDatei
Else
' LogEintrag "186 :: BakDatei ist nicht neuer als eine vorhande - Exit Function"
Exit Function
End If
DateiNr = DateiNr + 1
If Len( DateiNr ) < 3 Then DateiNr = "0" & DateiNr
If Len( DateiNr ) < 3 Then DateiNr = "0" & DateiNr
ZielDatei = ZielDatei & DateiNr & ZielEndg
fso.CopyFile BakDatei, ZielDatei
' LogEintrag "196 :: Zu kopieren (BakDatei) : " & BakDatei
' LogEintrag "197 :: Erstellte ZielDatei: " & ZielDatei
BakDateiSichern = ZielDatei & " (" & DateiDatum & ")"
' LogEintrag "200 :: Ende: BakDateiSichern = """ & BakDateiSichern & """ "
End Function ' BakDateiSichern( BakDatei, ZielVerz )
'*** v7.C *** www.dieseyer.de ****************************
Function Dateilisteholen( Verz )
'*********************************************************
' Die Prozedur
' Dateilisteholen( Verz )
' gibt ein Array mit dem kompletten Dateinamen von allen
' Dateien zurück, die in dem übergebenen Verzeichnis
' vorhanden sind. Ein rekursives Auflisten der Datein in
' Unterverzeichnissen erfolgt nicht!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Ausgeschl : Ausgeschl = Mid( WScript.ScriptName, 1 , InStrRev( WScript.ScriptName, "." ) )
' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
' LogEintrag "221 :: Ausgeschl: " & Ausgeschl
' LogEintrag "222 :: Verz: " & Verz
Dim i, oFolders, oFiles, DateiX
Set oFolders = fso.GetFolder( Verz )
Set oFiles = oFolders.Files
ReDim Preserve DateilisteholenX(i)
For Each DateiX In oFiles
If InStr( DateiX, Ausgeschl ) = 0 Then ' Dateien mit dem Namen des VBS, werden nicht an das Array übergeben
ReDim Preserve DateilisteholenX(i)
DateilisteholenX(i) = DateiX
' LogEintrag "232 :: i = " & i & vbTab & Dateilisteholen(i)
i = i + 1
End If
Next
Set oFiles = nothing
Set oFolders = nothing
Dateilisteholen = DateilisteholenX
End Function ' Dateilisteholen( Verz )
'*** v5.A *** www.dieseyer.de *******************************
Sub VBSbeenden()
'************************************************************
' Dim VBSmodTest
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
LogEintrag( "262 :: " & WScript.ScriptFullName & " existiert nicht!" )
LogEintrag( "263 :: " & WScript.ScriptFullName & " wird beendet . . . " & vbCRLF )
LogEintrag( "264 :: " & WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . " & vbCRLF )
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & VBSmodTest & " Durchläufen beendet . . . " , 30, "266 :: " & WScript.ScriptName, 64 + 4096
WScript.Quit
End Sub ' VBSbeenden()
'*** v9.1 *** www.dieseyer.de *******************************
Sub VBSneustart()
'************************************************************
' Dim VBSmodTime ' Muss beim Skriptaufruf als erstes ausgeführt werden !!!
' Dim VBSmodZahl ' für die Prozedur "Sub VBSneustart()" erforderlich
' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim SelbstVBS : SelbstVBS = WScript.ScriptFullName
On Error Resume Next
If not fso.FileExists( SelbstVBS ) Then Exit Sub
On Error GoTo 0
If VBSmodTime = "" Then VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified
If VBSmodTime = fso.GetFile( SelbstVBS ).DateLastModified Then Exit Sub
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "293 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "298 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "303 :: Das ALTE """ & SelbstVBS & """ wird jetzt beendet . . . ", 1
WScript.Quit
End Sub ' VBSneustart()
'*** v7.C *** www.dieseyer.de *******************************
Sub LogEintrag( LogTxt )
'************************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
' Dim LogDatei : LogDatei = "c:\LOG.s\" & WScript.Scriptname & ".log"
If LogTxt = "" Then
Set FileOut = fso.OpenTextFile( LogDatei, 2, true)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
Exit Sub
End If
Set FileOut = fso.OpenTextFile( LogDatei, 8, true)
If LogTxt = vbCRLF Then FileOut.WriteLine ( LogTxt )
' If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & vbTab & LogTxt )
If not LogTxt = vbCRLF Then FileOut.WriteLine ( Now() & " " & LogTxt )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> dateispeichernunter.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: dateispeichernunter.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit
Dim Txt
Txt = "1. Zeile" & vbCRLF
Txt = Txt & "2. Zeile" & vbCRLF
Txt = Txt & "3. Zeile" & vbCRLF
Txt = Txt & "4. Zeile" & vbCRLF
Dim ZielDatei : ZielDatei = "Zeilen.txt"
Call DatenInDateiSpeichernunter( ZielDatei, Txt )
CreateObject("WScript.Shell").Run "notepad " & ZielDatei, , False
Wscript.Quit
'*** v9.3 *** www.dieseyer.de ******************************
Sub DatenInDateiSpeichernunter( Datei, Txt )
'***********************************************************
Dim RC
Dim objDialog
Set objDialog = CreateObject("SAFRCFileDlg.FileSave")
objDialog.FileName = Datei
objDialog.FileType = "LST Dateien(*.lst)"
RC = objDialog.OpenFileSaveDlg
If RC Then CreateObject("Scripting.FileSystemObject").CreateTextFile( objDialog.FileName ).Write Txt
End Sub ' DatenInDateiSpeichernunter( Datei, Txt )
#########################################################################
>>> dateitypregistrieren.vbs <<<
'*** v9.5 *** www.dieseyer.de ******************************
'
' Datei: DateiTypRegistrieren.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Sub-Prozedur
' DateiTypRegistrieren( DateiTyp, Progr )
' legt ein Programm als Standard-Anwendung für einen
' Dateityp fest (Dateiendung registrieren). Bei einem
' Doppelklick auf eine Datei mit dieser Dateiendung öffnet
' sich künftig diese Anwendung und erhält als Parameter die
' doppelt geklickte Datei - so, wie Word geöffnet wird, wenn
' man eine .doc - Datei doppelt klickt.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Const TestEndung = "n-p"
Const TestProgr = "notepad.exe"
Dim TestDatei : TestDatei = WScript.ScriptFullName & "." & TestEndung
Dim Txt, Tst
Txt = ""
Txt = Txt & "Als erstes wird eine Datei mit der Endung '." & TestEndung & "' erstellt. Im Anschluß" & vbCRLF
Txt = Txt & "daran wird als Standard-Anwendung für '." & TestEndung & "'' - Dateien 'notepad'" & vbCRLF
Txt = Txt & "festgelegt (Dateiendung registrieren) und dann die '." & TestEndung & "'' - Datei" & vbCRLF
Txt = Txt & "gestartet - es sollte sich 'notepad' mit diesem Text öffnen." & vbCRLF & vbCRLF
Txt = Txt & "Mit dem Schließen von Notepad wird die registrierte Dateiendung " & vbCRLF
Txt = Txt & "wieder entfernt." & vbCRLF & vbCRLF
Txt = Txt & "Und? Soll 's los gehen?"
' Kontroll-Frage
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = MsgBox( Txt, vbQuestion + vbOkCancel, "038 :: " & WScript.ScriptName )
If not Tst = vbOK Then MsgBox " . . . dann eben nicht!", , "040 :: " & WScript.ScriptName : WScript.Quit
' Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("Scripting.FileSystemObject").OpenTextFile( TestDatei, 2, True).Write Txt
' Datei starten - es muss eine Fehlermeldung folgen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WScript.CreateObject("WScript.Shell").Run TestDatei, , True
Call DateiTypRegistrieren( TestEndung, TestProgr )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Datei starten - keine Fehlermeldung
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Run TestDatei, , True
WScript.Quit
'*** v9.5 *** www.dieseyer.de ******************************
Sub DateiTypRegistrieren( DateiTyp, Progr )
'***********************************************************
' in VBS und HTA verwendbar
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim ZielProgr : ZielProgr = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\dieseyer.de\" & fso.GetFileName( Progr )
Dim Zielverz : Zielverz = fso.GetParentFolderName( ZielProgr )
Dim HilfsProgr : HilfsProgr = ""
If fso.GetExtensionName( LCase( Progr ) ) = "vbs" Then HilfsProgr = "wscript.exe "
If fso.GetExtensionName( LCase( Progr ) ) = "hta" Then HilfsProgr = "mshta.exe "
DateiTyp = LCase( DateiTyp )
Dim Txt, Tst
Trace32Log "082 :: DateiTyp: " & DateiTyp, 1
Trace32Log "083 :: Progr: " & Progr, 1
Trace32Log "084 :: HilfsProgr: " & HilfsProgr, 1
Trace32Log "085 :: DateiTyp: " & DateiTyp, 1
Trace32Log "086 :: Zielverz: " & Zielverz, 1
' Ziel-Verzeichnis für das Progr ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FolderExists( Zielverz ) Then
Else
Trace32Log "092 :: Zielverz soll anlegt werden: " & Zielverz, 1
On Error Resume Next
fso.CreateFolder Zielverz
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Verzeichnis kann nicht ertellt werden:" & vbCRLF & vbCRLF & Tst
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "099 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "100 :: Verzeichnis kann nicht ertellt werden: " & Zielverz & " _ " & Tst, 3
Trace32Log "101 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "104 :: Erstellt: " & Zielverz & " _ " & Tst, 1
End If
End If
' Wenn Progr erreichbar, Prog ins Ziel-Verzeichnis kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn Progr NICHT erreichbar ist, wird davon ausgegangen,
' dass das Prog über die Umgebungsvariable PATH vom
' Betriebssystem gefunden wird.
If not fso.FileExists( Progr ) Then
ZielProgr = Progr
Trace32Log "115 :: ZielProgr (evtl. neu) festgelegt: " & ZielProgr, 1
Else
Trace32Log "117 :: Datei soll kopiert werden: (von..nach)", 1
Trace32Log "118 :: " & Progr, 1
Trace32Log "119 :: " & ZielProgr, 1
On Error Resume Next
fso.CopyFile Progr, ZielProgr, true
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Datei kann nicht ertellt werden:" & vbCRLF & vbCRLF & ZielProgr
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "126 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "127 :: Kann nicht erstellt werden: " & ZielProgr & " _ " & Tst, 3
Trace32Log "128 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "131 :: Erstellt: " & ZielProgr & " _ " & Tst, 1
End If
End If
Txt = "HKLM\SOFTWARE\Classes\." & DateiTyp & "\"
WSHShell.RegWrite Txt, DateiTyp & "_auto_file"
Trace32Log "137 :: RegWrite erfolgreich: " & Txt, 1
Txt = "HKLM\SOFTWARE\Classes\" & DateiTyp & "_auto_file\shell\open\command\"
WSHShell.RegWrite Txt, HilfsProgr & """" & ZielProgr & """ " & chr(34) & "%1" & chr(34)
Trace32Log "141 :: RegWrite erfolgreich: " & Txt, 1
Txt = vbTab & ZielProgr & vbCRLF & vbCRLF
Txt = Txt & "wurde als Standard-Anwendung für '" & DateiTyp & "' -Dateien registriert." & vbCRLF & vbCRLF
Txt = Txt & "Künftig genügt es, eine Datei mit der Endung ." & DateiTyp & " doppelt an zu" & vbCRLF
Txt = Txt & "klicken und die Anwendung startet mit dieser Datei als Parameter. " & vbCRLF
WSHShell.PopUp Txt, 30, "147 :: Sub 'DateiTypRegistrieren'", vbInformation
Trace32Log "149 :: Ende - Sub 'DateiTypRegistrieren'", 1
End Sub ' DateiTypRegistrieren( DateiTyp, Progr )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> dateizeilenweiselesenbearbeitenschreiben.vbs <<<
'v3.6*****************************************************
' File: DateiZeilenweiseLesenBearbeitenSchreiben.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Eine (ASCII_) Datei wird zeilenweise in ein Array gelesen,
' das Array bearbeitet und in eine Datei ausggegeben.
'*********************************************************
Option Explicit
Dim FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oArgs : set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird halt das Skript gelesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i = 0 : ReDim Preserve Zeile(i)
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = UBound( Zeile ) + 1 : ReDim Preserve Zeile(i) : Zeile(i) = FileIn.Readline
Loop
If UBound( Zeile ) < 1 Then
i = UBound( Zeile ) : ReDim Preserve Zeile(i) : Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
Zeile(i) = i+1 & vbTab & Zeile(i)
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = LBound( Zeile ) to UBound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOut = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.DeleteFile( Datei )
#########################################################################
>>> dateizlbs.vbs <<<
'*** v3.6 *** www.dieseyer.de *******************************
'
' Datei: DateiZeilenweiseLesenBearbeitenSchreiben.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Eine (ASCII_) Datei wird zeilenweise in ein Array gelesen,
' das Array bearbeitet und in eine Datei ausgegegeben.
'
'************************************************************
Option Explicit
Dim FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oArgs : set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird halt das Skript gelesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i = 0 : ReDim Preserve Zeile(i)
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = UBound( Zeile ) + 1 : ReDim Preserve Zeile(i) : Zeile(i) = FileIn.Readline
Loop
If UBound( Zeile ) < 1 Then
i = UBound( Zeile ) : ReDim Preserve Zeile(i) : Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
Zeile(i) = i+1 & vbTab & Zeile(i)
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = LBound( Zeile ) to UBound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOut = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.DeleteFile( Datei )
#########################################################################
>>> deltree.vbs <<<
'v3.6*****************************************************
' File: deltree.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Löscht alle Dateien und danach alle Verzeichnisse in
' einem Verzeichnis - vorher werden die Attribute gelöscht.
' Zieht man ein Verzeichnis auf das Skript, werden alle
' enthaltene Dateien und Unterverzeichnisse gelöscht.
' Zieht man eine Datei auf das Skript, wird das Verzeich-
' nis, in dem sich die Datei befindet, ermittelt und wie
' beschrieben gelöscht.
'*********************************************************
Option Explicit
Dim WSHShell, fso, oArgs
Dim i, Text, Pfad
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
If oArgs.Count > 0 Then ' gibt es Argumente?
Pfad = oArgs.item(0) ' erstes Argument
Else ' es gibt keine Argumente!
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Ein Verzeichnis auf das Skript ziehen & fallen lassen" & vbCRLF
Text = Text & ". . . und es wird gelöscht." & vbCRLF & vbCRLF
Text = Text & "Eine Datei auf das Skript ziehen & fallen lassen" & vbCRLF
Text = Text & ". . . und das Verzeichnis, in dem sich die Datei befindet wird gelöscht." & vbCRLF & vbCRLF
Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!"
WSHShell.Popup Text , 30, WScript.ScriptName, 64 + 0
WScript.Quit
End If
if not fso.FolderExists( Pfad ) then
WSHShell.Popup UCase(Pfad) & " entält kein Verzeichnis!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0
WScript.Quit
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SicherheitsAbfrage Pfad ' Sub Aufruf
if DelTree( Pfad ) = true then ' Function Aufruf
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.Popup UCase(Pfad) & " true ist jetzt leer!", 13, WScript.ScriptName, 64 + 0
Else
WSHShell.Popup UCase(Pfad) & " konnte nicht geleert werden!", 30, WScript.ScriptName, 48 + 0
End If
WScript.Quit
'*********************************************************
Function DelTree ( Pfad )
'*********************************************************
Dim fso, oFolders, oSubFolder, oFiles, WSHShell
Dim Text, DateiX, VerzX, Txt
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
DelTree = true
if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad )
' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist
' Datei-Attribute System, Readonly, Hidden zurück setzen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = "%comspec% /c Attrib """ & Pfad & "\*.*"" /S -s -r -h "
WSHShell.run Text, 4, True
' Dateiliste
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
Set oFolders = fso.GetFolder( Pfad )
Set oFiles = oFolders.Files
For Each DateiX In oFiles
Text = Text & DateiX.Path & vbCRLF
On Error Resume Next
fso.DeleteFile DateiX.Path, True ' True: Löschen erzwingen
if not err.number = 0 then DelTree = False
On Error GoTo 0
Next
Set oFiles = nothing
Set oFolders = nothing
If Text = "" then Text = "keine Dateien vorhanden."
WSHShell.Popup "In " & UCase(Pfad) & " wurden folgende Dateien gelöscht:" & vbCRLF & vbCRLF & Text, 3, WScript.ScriptName, 64 + 0
' Verzeichnisliste
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
Set oFolders = fso.GetFolder( Pfad )
Set oSubFolder = oFolders.SubFolders
For Each VerzX In oSubFolder
Text = Text & VerzX.Path & vbCRLF
On Error Resume Next
fso.DeleteFolder VerzX.Path, True ' True: Löschen erzwingen
if not err.number = 0 then DelTree = False
On Error GoTo 0
Next
Set oFiles = nothing
Set oFolders = nothing
If Text = "" then Text = "keine Unterverzeichnisse vorhanden."
WSHShell.Popup "In " & UCase(Pfad) & " wurden folgende Verzeichnisse gelöscht:" & vbCRLF & vbCRLF & Text, 3, WScript.ScriptName, 64 + 0
Set WSHShell = nothing
Set fso = nothing
End Function ' DelTree
'*********************************************************
'*********************************************************
Sub SicherheitsAbfrage( Pfad ) ' Anfang
'*********************************************************
Text = ""
Text = Text & "Es wird jetzt das Verzeichnis" & vbCRLF & vbCRLF
Text = Text & vbTAB & UCase( Pfad )
Text = Text & vbCRLF & vbCRLF & "unwiederbringlich gelöscht." & vbCRLF & vbCRLF
Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!"
If not vbYes = WSHShell.Popup ( Text , 30, WScript.ScriptName, 48 + 4 + 256 ) then
WSHShell.Popup UCase(Pfad) & vbTab & vbCRLF & vbCRLF & vbTab & "wird nicht gelöscht!" & vbCRLF & vbCRLF & vbTab & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0
WScript.Quit
End if
Text = vbCRLF
Text = Text & "DIE LETZTE WANUNG!" & vbCRLF & vbCRLF
Text = Text & "Es wird jetzt das Verzeichnis" & vbCRLF & vbCRLF
Text = Text & vbTAB & UCase( Pfad )
Text = Text & vbCRLF & vbCRLF & "unwiederbringlich gelöscht - dies betrifft auch Dateien mit " & vbCRLF
Text = Text & "SYSTEM, READONLY- oder HIDDEN-Attributen!" & vbCRLF & vbCRLF
Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!"
If not vbOK = WSHShell.Popup ( Text , 30, WScript.ScriptName, 16 + 1 + 256 ) then
WSHShell.Popup UCase(Pfad) & vbTab & vbCRLF & vbCRLF & vbTab & "wird nicht gelöscht!" & vbCRLF & vbCRLF & vbTab & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0
WScript.Quit
End if
Text = ""
Set fso = nothing
End Sub ' SicherheitsAbfrage
'*********************************************************
#########################################################################
>>> dez2hex.vbs <<<
'v3.3*****************************************************
' File: Dez2Hex.vbs
' Autor: Hubert Daubmeier / hubertd@neusob.de
' http://www.neusob.de/scripting
'
' Wandelt eine Dezimal- in eine Hex-Zahl; für Zahlen von
' 0 bis 100 Milliarden. Bei Fließkommazahlen größer 2^53
' könnte es zu Rundungsfehlern kommen. Bei Zahlen zw.
' 2^53 bis 2^96 müßte man evtl. auf den Datentyp Währung
' ausweichen.
'*********************************************************
Option Explicit
MsgBox BigHex( 255 )
MsgBox BigHex( 2^52+1 )
MsgBox BigHex( 2^53-1 )
MsgBox BigHex( 2^53+1 )
Function BigHex(ByVal X)
Dim A, D
BigHex = ""
A = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")
Do While X > 0
D = X - 16 * Fix(X / 16)
BigHex = A(D) & BigHex
X = (X - D) / 16
Loop
If BigHex = "" Then BigHex = "0"
End Function
#########################################################################
>>> dhcpenable.vbs <<<
'-----------------------------------------------------------------------
' The following script reads the registry value name IPAddress to
' determine which registry entries need to be changed to enable DHCP.
' This sample checks the first 11 network bindings for TCP/IP, which is
' typically sufficient in most environments.
' ----------------------------------------------------------------------
' from http://support.microsoft.com/default.aspx?scid=kb;EN-US;q197424
Dim WSHShell, NList, N, IPAddress, IPMask, IPValue, RegLoc
Set WSHShell = WScript.CreateObject("WScript.Shell")
NList = array("0000","0001","0002","0003","0004","0005","0006", "0007","0008","0009","0010")
On Error Resume Next
RegLoc = "HKLM\System\CurrentControlSet\Services\Class\NetTrans\"
For Each N In NList
IPValue = "" 'Resets variable
IPAddress = RegLoc & N & "\IPAddress"
IPMask = RegLoc & N & "\IPMask"
IPValue = WSHShell.RegRead(IPAddress)
If (IPValue <> "") and (IPValue <> "0.0.0.0") then
WSHShell.RegWrite IPAddress,"0.0.0.0"
WSHShell.RegWrite IPMASK,"0.0.0.0"
end If
Next
WScript.Quit ' Tells the script to stop and exit.
#########################################################################
>>> dir2htmlview.vbs <<<
'v3.5 ****************************************************************
' Funktion:
' Das Skript öffnet eine HTML-Datei und zeigt in einem Frame
' die Dateien des gedroppten Ordners an. Benötigt ein Unter-
' verzeichnis (FrameScroller) mit einigen Spezialdateien.
'
' Übergebene Argumente :
' - kein Argument übergeben: Nachfrage: aktuelles Verzeichnis oder Abbruch.
' - nur ein Argument übergeben (eine Datei): übergeordneten
' Ordner holen, alle Dateien darin durchgehen
' - nur ein Argument übergeben (einen Ordner): ganzen Ordner
' holen, alle Dateien darin durchgehen
' - mehrere Argumente übergeben: Argumente einzeln auswerten:
' ist das aktuelle Argument eine Datei, diese eintragen
' (aber nicht den übergeordneten Ordner, dies nur bei einer
' einzigen übergebenen Datei)
' - ist das aktuelle Argument ein Ordner, alle Dateien dieses
' Ordners eintragen.
'
' Man kann also:
' - Drei Html-Dateien aus einem Ordner (mit vielen Html-Dateien)
' droppen, um nur in diesen dreien zu blättern.
' - Ordner droppen, um alle html/Text/Bild-Dateien darin zu sehen
' - eine Datei droppen, um alle in ihrem Verzeichnis zu sehen
' - einen Ordner und zwei Dateien droppen: man sieht alle
' Dateien in diesem Verzeichnis und die beiden Dateien (aber
' keine weiteren Dateien aus ihrem Ordner; s.o.)
'
' Ferner kann man:
' - die erlaubten Endungen (htm, html, txt...) verändern
' - das Script auf den Desktop legen und per Drag und Drop starten
' - eine Verknüpfung auf dieses Script in den SendTo-Ordner kopieren
' und per rechter Maustaste | Senden an starten
' - dieses Script perBatch-Datei starten
'
' Erfordert: WSH 2.0 / 5.5, Internet Explorer, Spezialdateien
'
' Version um 13:35 am 29.05.2003.
'
' Ralf Nebelo (c't 24 / 2001, S.264) & Christoph Römhild
' (veröffentlicht auf http://dieseyer.de)
' ****************************************************************
Option Explicit
' ****************************************
Const strErlaubte_Endungen = ".htm.html.shtml.txt.pdf.jpg.jpe.gif.tif.png.bmp" ' In der Form: ".htm.html" (mit Punkten)
Const strVersion = "um 13:35 am 29.05.2003" ' z.B. "um 17:08 am 24.05.2003"
Const strTitel = "Verzeichnis als Internet-Explorer Frame zeigen" ' Titel
Dim objFS ' Filesystem-Object
' Aufruf Main
Main
' ****************************************
Sub Main
' Pfade und Dateien
Const strConstPathFolder = "\FrameScroller" ' der Folder
Const strConstPath1 = "\LoadTMP.js" ' Temporäre Datei in der Form "\FrameScroller\LoadTMP.js"
Const strConstPath2 = "\Start.html" ' Framerahmen in der Form "\FrameScroller\Start.html"
Const strConstPath3 = "\Loader.js" ' Javascript in der Form "\FrameScroller\Loader.js"
Dim strDateiListe ' zu erstellender String
Dim strMeldung ' für MsgBox-Meldungen
Dim strArg ' Argumente von Kommandozeile
Dim strPathScript ' Pfad des Skriptes
Dim strPathFolder ' Pfad des Ordners FrameScroller (analog zu oben)
Dim strPath1 ' Temporäre Datei (analog zu oben)
Dim strPath2 ' Framerahmen (analog zu oben)
Dim strPath3 ' Javascript (analog zu oben)
' Init ********************************************
' Filesystem-Object holen
Set objFS = WScript.CreateObject("Scripting.FileSystemObject")
' Pfade erstellen
strPathScript = objFS.GetParentFolderName( wscript.ScriptFullname )
strPathFolder = strPathScript + strConstPathFolder
strPath1 = strPathFolder + strConstPath1
strPath2 = strPathFolder + strConstPath2
strPath3 = strPathFolder + strConstPath3
' String strDateiListe erstellen ******************
' strDateiListe ist die zu bildende Liste
' sieht so aus : strDateiListe = "MeineDateien = new Array("file://c:/filme1.htm","file://c:/weltall1.htm","file://c:/texte1.htm");"
' Anfang der Zeile setzen :
strDateiListe = "MeineDateien = new Array("
' Je nach Anzahl der übergebenen Argumente : ******
' Dieser Block startet alles weitere wichtige
If Wscript.Arguments.Count = 0 Then
' Frage stellen
strMeldung = "Keine Dateien oder Ordner gedroppt. " & vbNewLine
strMeldung = strMeldung + "Soll statt dessen der Ordner des Skriptes in einem Frame dargestellt werden?"
if MsgBox (strMeldung, vbyesnocancel + vbquestion, strTitel) = vbyes then
call EinElementAuswerten (strPathScript, strDateiListe)
else
WScript.Quit ' Abbruch
end if
Elseif Wscript.Arguments.Count = 1 Then
' es wurde nur ein Argument übergeben; wenn Datei, dann übergeordneter Ordner; wenn Ordner, dann so lassen
strArg = OrdnerAusArgument ( 0 )
' Ist es Datei oder Ordner?
if strArg = "" then
' Weder Datei noch Ordner (z.B. /?)
AuswertungKommandzeilenParameter ( Wscript.Arguments(0) ) ' ggf. Hilfe oder Version anzeigen
WScript.Quit ' Abbruch
else
' Alles ok, strArg ist ein Pfad / Datei oder Ordner o.ä.
call EinElementAuswerten ( strArg, strDateiListe )
end if
Elseif Wscript.Arguments.Count > 1 Then
' Alles ok
call AlleArgumenteDurchgehen ( strDateiListe )
Else
' Fehler (Count < 0 oder ähnliches)
msgbox "Unbekannte Anzahl der Argumente", vbInformation, strTitel
End If ' End If von Je nach Anzahl der übergebenen Argumente
' ggf. Abbruch ************************************
If FolderExistsExtended (strPathFolder) = False Then WScript.Quit
If FileExistsExtended (strPath2) = False Then WScript.Quit
If FileExistsExtended (strPath3) = False Then WScript.Quit
If Len(strDateiListe) <= 25 then
strMeldung = "Keine Dateien gefunden."
msgbox strMeldung, vbcritical, strTitel
WScript.Quit ' Abbruch
end if
' write strDateiListe to LoadTMP.js ***************
call SchreibeStringInEinFile (strDateiListe, strPath1)
' Explorer starten ********************************
StarteProgramm "iexplore.exe", strPath2
end sub ' Ende von Main
' ************************************************************
' ************************************************************
' zentrale Subs
sub AlleArgumenteDurchgehen( strDateiListe )
' wird nur von Main gestartet
Dim intI
Dim strArg
' Alle Argumente durchgehen
For intI = 0 To Wscript.Arguments.Count - 1
' Argument einlesen
strArg = WScript.Arguments( intI )
' Argument auswerten
call EinElementAuswerten (strArg, strDateiListe )
Next ' Next Argument
end sub
' ************************************************************
sub EinElementAuswerten (strArg, strDateiListe )
' wird von Main oder von AlleArgumenteDurchgehen gestartet
Dim objFile
' Argument auswerten
If objFS.FolderExists( strArg ) = True Then
' Es ist ein Ordner :
' Alle Dateien im Ordner durchgehen
For Each objFile In objFS.GetFolder( strArg ).Files
call SchreibeString ( objFile, strDateiListe )
Next ' Next Datei
ElseIf objFS.FileExists(strArg) = True Then
' Es ist eine Datei : Direkt schreiben:
Set objFile = objFS.GetFile(strArg)
Call SchreibeString ( objFile, strDateiListe )
Else
' Fehler: weder noch (dieses Argument übergehen, mit dem nächsten fortfahren)
msgbox "Datei oder Ordner existiert nicht: " & vbnewLine & strArg, vbinformation, strTitel
End If
end sub
' ************************************************************
sub SchreibeString ( objLocalDatei, strDateiListe )
' wird nur von EinElementAuswerten gestartet
Dim strFile
Dim strEndung
' Dateiname holen
strFile = LCase(objLocalDatei.path)
' Endung einlesen
strEndung = objFS.GetExtensionName(strFile)
' Wenn Endung erlaubt (ignoriert also alle zips und exes etc.); Dateien ohne Endung ignorieren
If InStr ( 1, strErlaubte_Endungen, strEndung ) > 0 and strEndung <> "" Then
' dann zu bildende Liste ergänzen; dabei muss \ durch / ersetzt werden; chr(34) ist ein "
strDateiListe = strDateiListe + chr(34) + "file://" + Replace (strFile,"\","/") + chr(34) + ","
End If
end Sub
' ************************************************************
' ************************************************************
' Hilfs-subs
function OrdnerAusArgument ( intNummerDesArguments )
' Argument Nummer "intNummerDesArguments" der Kommandozeile lesen;
' wenn Ordner, diesen zurückgeben;
' wenn Datei, deren übergeordneten (enthaltenden) Ordner zurückgeben.
Dim strPath ' Puffer für Rückgabewert
Dim objFolder ' Object Folder
Dim objFile ' Object File
Dim strArgument ' Argument aus Kommandozeile
' Wurden Argumente übergeben?
If WScript.Arguments.count <= 0 then
' Nein, nichts, Rückgabewert zwischenspeichern
strPath = ""
Else
' Ja, es wurde etwas übergeben; Argument speichern
strArgument =WScript.Arguments( intNummerDesArguments )
End if
' Ist es eine Datei?
If objFS.FileExists (strArgument) then
' Ja, Datei :
set objFile = objFS.GetFile(strArgument)
' Rückgabewert zwischenspeichern
strPath = objFS.getParentFolderName (objFile.shortpath)
' Wenn nicht: Ist es ein Ordner?
ElseIf objFS.FolderExists (strArgument) then
' Ja, Ordner :
Set objFolder = objFS.GetFolder(strArgument)
' Rückgabewert zwischenspeichern
strPath = objFolder.ShortPath
Else
' Weder Datei noch Ordner (z.B. gelöschte Datei); Rückgabewert zwischenspeichern
strPath = ""
End if
' Rückgabewert setzen
OrdnerAusArgument = strPath
End function
' ************************************************************
sub AuswertungKommandzeilenParameter (strArg)
' Nur einen Parameter, der weder Datei noch Ordner ist, auswerten.
' z.B. für /? etc.
Dim strMeldung ' für MsgBox-Meldungen
Dim strArgAlsLCase ' in Kleinbuchstaben
' vorbereiten
' Kleinbuchstaben
strArgAlsLCase = Trim( LCase ( strArg ) )
' Das vbs Case kennt kein oder (Or), deshalb hier vereinheitlichen :
if strArgAlsLCase = "/?" or strArgAlsLCase ="?" or _
strArgAlsLCase ="/help" or strArgAlsLCase ="help" or _
strArgAlsLCase ="/h" or strArgAlsLCase ="h" or _
strArgAlsLCase ="/hilfe" or strArgAlsLCase ="hilfe" then
strArgAlsLCase = "/?"
end if
if strArgAlsLCase = "/v" then
strArgAlsLCase = "/version"
end if
' auswerten
select Case strArgAlsLCase
case "/?"
strMeldung = "Hilfe zu dir2htmlview." & vbnewline
strMeldung = strMeldung & vbnewline & "Schreibt ein Dateininhaltsverzeichnis des gedroppten Ordners in ein Frame." & vbnewline
strMeldung = strMeldung & "Braucht ein Unterverzeichnis (FrameScroller) mit einigen Spezialdateien."
MsgBox strMeldung, vbInformation, strTitel
case "/version"
strMeldung = "Version lautet " + strVersion
msgbox strMeldung , vbInformation, strTitel
case else
strMeldung = "Keine Dateien oder Ordner gedroppt. Das Skript konnte Ihren Parameter nicht erkennen. "
strMeldung = strMeldung & vbnewline & "Der Parameter lautete: " & vbnewline
strMeldung = strMeldung & strArg & vbnewline & "Eventuell ist die Datei oder der Ordner gelöscht worden."
strMeldung = strMeldung & vbnewline & vbnewline & "Verwenden Sie /? für Hilfe."
msgbox strMeldung, vbcritical, strTitel
end select
end sub
' ************************************************************
function FolderExistsExtended (strPathFolder )
Dim strMeldung ' für MsgBox-Meldungen
FolderExistsExtended = true
If objFS.FolderExists ( strPathFolder ) = False Then
strMeldung = "Ein wichtiger Ordner existiert nicht. "
strMeldung = strMeldung & vbnewline & "Deshalb Abbruch." & vbnewline
strMeldung = strMeldung & "Name des Pfads: " & vbnewline & strPathFolder & "."
MsgBox strMeldung, vbInformation, strTitel
FolderExistsExtended = false
End If
end function
' ************************************************************
function FileExistsExtended (strPath)
Dim strMeldung ' für MsgBox-Meldungen
FileExistsExtended = true
If objFS.FileExists ( strPath ) = False Then
strMeldung = "Eine wichtige Datei existiert nicht. "
strMeldung = strMeldung & vbnewline & "Deshalb Abbruch." & vbnewline
strMeldung = strMeldung & "Pfad der Datei: " & vbnewline & strPath & "."
MsgBox strMeldung, vbInformation, strTitel
FileExistsExtended = false
End If
end function
' ************************************************************
sub SchreibeStringInEinFile (strDateiListe, strPath1)
' fertigen String aus RAM in die Datei auf der Festplatte schreiben
Dim objTextFile
' letztes Komma wieder weg :
strDateiListe = Left ( strDateiListe, Len(strDateiListe)-1 )
' Klammer am Ende setzen :
strDateiListe = strDateiListe + ");"
' write strDateiListe to LoadTMP.js ***************************
' Datei erstellen, alte überschreiben :
Set objTextFile = objFS.OpenTextFile(strPath1, 2, True)
' schreiben :
objTextFile.WriteLine(strDateiListe)
' schliessen :
objTextFile.Close
end sub
' ************************************************************
sub StarteProgramm (Path, Parameter)
' startet z.B. den Internet Explorer
Dim objShell
Dim strAufruf
Set objShell = WScript.CreateObject ("WScript.Shell")
strAufruf = Path & " " & Parameter
' starte Programm mit Parameter und Vollbild und warte nicht
objShell.run strAufruf, 3, True
end sub
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#########################################################################
>>> diranalyze.vbs <<<
'v4.7*****************************************************
' File: DirAnalyze.vbs
' Autor: Mueller@tensor.de
' www.tensor.de
'
' Findet verdächtig lange Verzeichnisnamen im Dateisystem
' und speichert sie in einer Logdatei.
'
' Muss mit administrativen Rechten ausgeführt werden!!!
' Wenn der Administrator nicht überall zumindest Lesesrechte
' hat, meldet das Programm für das erste zutreffende Verzeichnis
' einen Fehler und bricht die Verarbeitung ab
'*********************************************************
Option Explicit
Dim WSHShell, fso, oArgs
Dim Pfad, j, MaxNameLen,k, i
Dim StartVerz, Limit
Dim FoundMinus1, Longest
Dim Fileout, fsolog
Dim Drives(30)
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set oArgs = Wscript.Arguments
If oArgs.Count <> 2 Then
Wscript.Echo "Aufruf: <Zu untersuchendes Laufwerk; alternativ 'ALL' oder LOCAL> <Limitlänge> (als Zahl>100)"
WScript.Echo "Beispiel: Diranalyze ALL 180"
WScript.Echo "--> Die gesamte Laufwerksliste wird auf Verzeichnisnamen länger als 180 Zeichen analysiert"
Wscript.Quit 1
End If
If not isnumeric(oArgs(1)) then
Wscript.Echo "Ihr zweiter Aufrufparameter ist nicht numerisch."
Wscript.Quit 1
end if
If oArgs(1) < 100 then
Wscript.Echo "Der Parameter 'Maximale Länge' ist zu klein gewählt."
Wscript.Quit 1
end if
limit = cint(oArgs(1))
ClearLogDatei
FoundMinus1=" "
j=0
MaxNameLen=0
For i=0 To 30
Drives(i)= " "
Next
EvaluateLWs
IF NOT fso.FolderExists(Drives(0) & "\") Then
'hier verlassen wir uns drauf, das EvaluateLWs exakt arbeitet
WScript.Echo Drives(0) & " ist kein gültiges Laufwerk."
WScript.Quit 1
End If
i=0
Do While Drives(i) <> " "
Set Startverz = fso.GetFolder(Drives(i) & "\" )
DirsRecursive Startverz
i= i + 1
Loop
Logdatei(vbCrLf & "Maximal gefundene Namenslänge: " & MaxNameLen & " und zwar in:")
Logdatei(Longest)
CloseLogDatei
wscript.echo "Fertig, " & j & " Verzeichnisnamen mit mehr als " & limit & " Zeichen Länge gefunden."
If MaxNameLen > 220 Then wscript.Echo "Es gibt kritisch lange Dateinamen mit mehr als 220 Zeichen - sichten Sie die Logdatei!"
Sub DirsRecursive (Startpfad)
Dim MySubFolders
Dim MyFolder
Dim NameLen
If UCase(Startpfad)=Drives(i) & "\SYSTEM VOLUME INFORMATION" Then Exit sub
Set MySubFolders = Startpfad.SubFolders
'Vorbereitung Rekursiver Aufruf, Unterverzeichnisse zuerst.
On Error Resume Next
k = MySubFolders.Count
If Not err.number = 0 Then
Select Case err.number
Case 70
logdatei("Berechtigungsproblem im Ordner " & Startpfad)
wscript.Echo "Kann die Datenmenge nicht verarbeiten, solange Sie nicht über die notwendigen Berechtigungen verfügen."
wscript.Echo "Fehler trat im Pfad " & Startpfad & " auf. Übernehmen Sie ggf. Besitz über das Laufwerk und erteilen Sie sich dann zumindest Leserechte!"
Case 76
logdatei("Ordnername zu lang und zwar in " & Startpfad)
wscript.Echo "Kann die Datenmenge nicht verarbeiten, solange kritisch lange Ordnernamen auftreten."
wscript.Echo "Fehler trat im Pfad " & Startpfad & " auf. Kürzen Sie die Namen, indem Sie die Struktur nach oben VERSCHIEBEN!"
End Select
Logdatei(vbCrLf & "Bis hierher gefundene maximale Namenslänge: " & MaxNameLen & " und zwar in:")
Logdatei(Longest)
CloseLogDatei
wscript.Quit
End If
On Error GoTo 0
If k <> 0 Then
For each MyFolder in MySubFolders
DirsRecursive MyFolder
namelen=len (MyFolder.path)
if NameLen>MaxNameLen then
MaxNameLen=NameLen
Longest = MyFolder.path
end if
if namelen > limit then
'Pfadnamen, die länger als limit Zeichen sind, werden sofort in die Logdatei geschrieben -->
'der erste Pfadname, der das Kriterium erfüllt ist, bedingt durch den rekursiven Aufruf, der innerste auflösbare
'der nächste Pfadname könnte immer noch länger als limit Zeichen sein, obwohl er übergeordnete des vorhergehenden ist -->
'der interessiert aber nicht mehr --> daher dieser instr- Vergleich. Und besonders schön: Durch Rekursion
'tauchen übergeordnete zu lange immer als Nachfolger des schon gefundenen auf. NUR DESHALB ist Vergleich statthaft.
if instr (1, FoundMinus1 , MyFolder.path,1) = 0 then
FoundMinus1=MyFolder.path
'Letzten gefundenen speichern
If namelen>220 Then LogDatei("KRITISCH: "& MyFolder.path) Else LogDatei(MyFolder.path)
j=j+1
if j>=1000 then
LogDatei("Zu viele Treffer - zu unscharfe Parameter oder sehr viele Probleme mit zu langen Namen.")
Wscript.echo("Programm beendet - zu viele Treffer")
wscript.quit
end if
end if
end if
Next
End If
End Sub
'------------------------------------------------------------------------------------------
'End of DirsRecursive
'------------------------------------------------------------------------------------------
Sub LogDatei (LogTxt)
fileOut.WriteLine (LogTxt)
End Sub ' LogDatei
' **************************************************************
' **************************************************************
Sub ClearLogDatei
' **************************************************************
Set fsolog = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( fsolog.GetBaseName( WScript.ScriptName ) & ".log", 2, true)
End Sub ' ClearLogDatei
' **************************************************************
' **************************************************************
Sub CloseLogDatei
' **************************************************************
Fileout.Close
Set FileOut = Nothing
End Sub ' CloseLogDatei
' **************************************************************
sub EvaluateLWs
Dim fso, d, dc, i
Set fso = CreateObject("Scripting.FileSystemObject")
Set dc = fso.Drives
i=0
If InStr(1,oArgs(0),":",1) Then
Drives(0) = oArgs(0)
Exit Sub
End if
For Each d in dc
' Case 0: t = "Unbekannt"
' Case 1: t = "Austauschbar"
' Case 2: t = "Fest"
' Case 3: t = "Netzwerk"
' Case 4: t = "CD-ROM"
' Case 5: t = "RAM-Laufwerk"
If d.Drivetype=2 Then
Drives(i)=D.Driveletter & ":"
i = i + 1
End If
If d.Drivetype=3 Then
If ucase(oArgs(0)) = "ALL" Then
Drives(i)=D.Driveletter & ":"
i = i + 1
End If
End If
Next
End Sub
#########################################################################
>>> disk0-test.vbs <<<
'v7.2*****************************************************
' File: disk0-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt Infos zu Laufwerk C:, die von DISKPART.EXE stammen.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Txt, Tst, i
Dim oExec
Const HDD = "DISK 0"
' Größe der HDD ermitteln
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set oExec = WSHShell.Exec( "diskpart.exe" )
Do While Not oExec.StdOut.AtEndOfStream
WScript.Sleep 15
Txt = oExec.StdOut.ReadLine
Tst = Tst & Txt & vbCRLF
' MsgBox Txt & vbCRLF & vbCRLF & Tst, , "0029 :: " ' zeigt in der ersten Zeile die letzte Ausgabe
If InStr( UCase( Txt ), "COMPUTER" ) > 0 Then oExec.StdIn.Write "list disk" & vbCRLF
If InStr( UCase( Txt ), "GB " ) > 0 Then oExec.StdIn.Write "exit" & vbCRLF : Exit Do
WScript.Sleep 15
Loop
oExec.Terminate
Set oExec = nothing
MsgBox Tst, , "0039 :: " ' Anwendung ist beendet
Tst = Split(Txt, " ", -1)
For i = LBound( Tst ) to UBound( Tst )
If InStr( Tst(i), "GB" ) Then Txt = Tst(i-1) ' Größe der HDD in GB
Next
Txt = "Laufwerk C: ist " & Txt & " GB groß."
WSHShell.Popup Txt ,30 , "0048 :: " & WScript.ScriptName, 4096 + 256
WScript.Quit
#########################################################################
>>> dns-eintragtest.vbs <<<
'v2.A*****************************************************
' File: DNS-EintragTest.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Testet ob ein Gerät über DNS aufgelöst wird.
' Wenn DNS-Einträge nur von Hand in eine DNS-Tabelle
' gesetzt werden, testet dieses Skript, bis eine IP-Adr.
' zurück gegeben wird.
' Zeigt das Skript nur stündlich Ergebnisse, beendet sich
' das Skript, wenn die .log-Datei in .end umbenannt wird.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
DIM DefaultGW, Ziel, Text, TextX, Text1, Text2, Button, FileIn, i, x, y, z, MsgTxt, IPtst
Dim Server, Msg, IPSrv
DIM WSHShell, FSO, WSHNet
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Server = "WinNTSRV"
Text = "Von welchem Server soll ermittelt werden, " & vbCRLF
Text = Text & "ob er über WINS oder DNS erreichbar ist?"
Server = UCase(Server)
Server = InputBox (Text, WScript.ScriptName, Server)
If Server = "" then Server = InputBox (Text, WScript.ScriptName)
If Server = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Server = "" then WScript.Quit
Server = UCase(Server)
Ziel = Server & ".tmp"
DefaultGW = ""
' Router / DefaultGateWay festgelegt?
'*********************************************************
GateWayNT ' Sub Aufruf, ob ein DefaultGateWay in der Netz-Config hinterlegt ist
'~~~~~~~~~~~~~~~~~~~~~~
TextX = "Das Netzwerk ist nicht bereit bzw. es ist " & vbCRLF
TextX = TextX & "kein DefaultGateway eingetragen oder erreichbar." & vbCRLF & vbCRLF
TextX = TextX & "DNS-Eintragstest trotzdem ausführen? [OK] nach 15s."
If DefaultGW = "" then
LogDatei (now() & vbTab & Server & " - Default GateWay nicht festgelegt.")
Button = wshshell.Popup( TextX, 15, WScript.ScriptName, 48+1)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
End If
' Router / DefaultGateWay bereit?
'*********************************************************
If not DefaultGW = "" then
IPtst = DefaultGW
IPTest ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~~~~~
if not Text1 = "True" then
wshshell.Popup "Router- / GateWay-Test:" & vbCRLF & DefaultGW & "antwortet nicht." & vbCRLF & vbCRLF & ". . . das ist das ENDE!" , 30, WScript.ScriptName, vbExclamation
LogDatei ( now() & vbTab & Server & " - Default GateWay " & DefaultGW & " antwortet nicht.")
WScript.Quit
End If
End If
' Test ob DNS angelegt ist
'*********************************************************
IPSrv = ""
Msg = "yes"
Do ' Do - Loop bis eine IP-Adr. für den PC (-Name) per WINS/DNS mitgeteilt wird
IPAdr ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~~~~~
' IPAdr. aus WINS / DNS ermitteln
if not IPSrv = "" then Exit Do
LogDatei (now() & vbTab & Server & " - IP-Adr. nicht bekannt.")
Text = "Von dem Server " & UCASE(Server) & vbCRLF
Text = Text & "konnte keine IP-Adr. ermittelt werden. " & vbCRLF & vbCRLF
Text = Text & UCASE(Server) & " erneut testen und jedes Testergebnis anzeigen?" & vbCRLF
Text = Text & "[Ja] nach 15s. [Nein] stündlich Testergebnisse anzeigen."
If "NO" = UCase(Msg) then
i = i + 1
WScript.Sleep 60*1000 ' nur minütlich testen
if i > 58 then ' nur stündlich anzeigen
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "NO"
if Button = vbYes then Msg = "yes"
i = 0
End If
End If
If not "NO" = UCase(Msg) then
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "yes"
if Button = vbNo then Msg = "NO"
i = 0
End If
Loop
Msg = "yes"
Do ' Do - Loop bis der PC (-Name) auf PING antwortet
IPtst = IPSrv
' Antwortet die IP-Adr. ?
IPtest ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~~~~~
If Text1 = "True" then Exit Do
LogDatei (now() & vbTab & Server & " mit IP-Adr. " & IPSrv & " antwortet nicht.")
Text = "Der Server " & UCASE(Server) & " hat die IP-Adr. " & IPSrv & vbCRLF & vbCRLF
Text = Text & "und antwortet auf PING-Anfragen nicht. " & vbCRLF & vbCRLF
Text = Text & UCASE(Server) & " erneut testen und jedes Testergebnis anzeigen?" & vbCRLF
Text = Text & "[Ja] nach 15s. [Nein] stündlich Testergebnisse anzeigen."
' If "NO" = UCase(Msg) then Exit Do
If "NO" = UCase(Msg) then
i = i + 1
WScript.Sleep 60*1000 ' nur menütlich testen
if i > 58 then ' nur stündlich anzeigen
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "NO"
if Button = vbYes then Msg = "yes"
i = 0
End If
End If
If not "NO" = UCase(Msg) then
Button = wshshell.Popup(Text , 15, UCase( Msg ), 32+3)
if Button = vbCancel then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
if Button = vbCancel then WScript.Quit
Msg = "yes"
if Button = vbNo then Msg = "NO"
i = 0
End If
Loop
Text = "Der Server " & vbTab & Server & vbCRLF & "hat die IP-Adr. " & vbTab & IPSrv & vbCRLF
Text = Text & "und beantwortet PING-Anfragen."
MsgBox Text, 64, WScript.ScriptName
LogDatei (now() & vbTab & Server & " mit IP-Adr. " & IPSrv & " antwortet.")
WScript.Quit
'**********************
Sub GateWayNT
'**********************
WshShell.run ("%comspec% /c ipconfig > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
DefaultGW = ""
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(UCase(TextX(i)), "GATEWAY") then
DefaultGW = Mid(TextX(i), InStr(UCase(TextX(i)), ": ") + 1)
DefaultGW = trim(DefaultGW) ' Leerzeichen entfernen
If not 5 < Instr( Instr( (Instr( DefaultGW, "." )+1 ), DefaultGW, ".") +1, DefaultGW, ".") then DefaultGW = ""
' wenn der dritte Punkt (der IP-Adr.) nicht wenigstens an Stelle 6 steht: DefaultGW = ""
End If
next
End Sub ' GateWayNT
'**********************
Sub IPTest
'**********************
' Test ob IP-Adr. erreichbar bereit ist
WshShell.run ("%comspec% /c Ping " & IPtst & " -n 1 -w 500 > " & Ziel),0,true
' PING nur einmal ausführen => nur eine Zeile mit TTL=
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
Text2 = "False"
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text2 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr(Text2, "TTL=") > 1 then
Text1 = "True"
' MsgBox Text2
End If
Loop
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
End Sub ' IPTest
'**********************
Sub IPAdr
'**********************
' IP-Adr. feststellbar?
WshShell.run ("%comspec% /c Ping " & Server & " -n 2 -w 500 > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text1 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr(Text1, "[") AND InStr(Text1, "]") then
IPSrv = Mid( Text1, InStr(Text1, "[") + 1, InStr( Text1, "]" ) - InStr(Text1, "[") -1)
End If
Loop
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
End Sub ' IPAdr
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
if fso.FileExists( WScript.ScriptName & "_" & Server & "_.end" ) then
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & "_" & Server & "_.end", 8, true)
FileOut.WriteLine (LogTxt)
Text = WScript.ScriptName & "_" & Server & "_.end existiert!" & vbCRLF
Text = Text & "--- Skript wird beendet. ---" & vbCRLF
FileOut.WriteLine (Text)
FileOut.Close
Set FileOut = Nothing
Button = wshshell.Popup( Text, 60, WScript.ScriptName, 48)
WScript.Quit
Else
Set FileOut = fso.OpenTextFile( WScript.ScriptName & "_" & Server & "_.log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End If
End Sub ' LogDatei
#########################################################################
>>> dnstesten.vbs <<<
'*** v10.5 *** www.dieseyer.de *****************************
'
' Datei: AAAAA.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Liest das Verbindungsspez. DNS-Suffix, der normalerweise
' per DHCP auf dem Client gesetzt wird.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox "Verbindungsspez. DNS-Suffix: " & DNSTesten( "." ), vbInformation, WScript.ScriptName
WScript.Quit
'*** v10.5 *** www.dieseyer.de *****************************
Function DNSTesten( PC )
'***********************************************************
' Liest das Verbindungsspez. DNS-Suffix, der normalerweise
' per DHCP auf dem Client gesetzt wird.
Dim objWMIService, colAdapters, objAdapter
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colAdapters = objWMIService.ExecQuery ("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
For Each objAdapter in colAdapters
If IsNull( objAdapter.DNSDomain ) = 0 Then DNSTesten = objAdapter.DNSDomain : Exit For
Next
End Function ' DNSTesten( PC )
#########################################################################
>>> druckerauswahl.vbs <<<
'v3.C***********************************************************
' File: DruckerAuswahl.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Bietet eine Auswahl der Netzwerk- bzw. der lokalen Drucker;
' Virtuelle Drucker (PDF) stehen nicht zur Auswahl - das läßt
' sich aber ändern.
'***************************************************************
Option Explicit
Dim Drucker
' WSHShell.run UCase("net use lpt2 /DELETE") , 0, True
' WSHShell.run UCase("net use lpt2: \\PrintSrv\LJ4plus") , 0, True
If Drucker = "" then Drucker = Druckerauswahl ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox Drucker, , WScript.ScriptName
WScript.Quit
'***************************************************************
Function Druckerauswahl ' Anfanfg
'***************************************************************
Dim i, n, Text, DruckerNr, NetPRN, WSHNet
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
n = 0
' welche Drucker sind verwendbar:
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
End If
Next
Text = Text & vbCRLF & "Auf welchen Drucker soll gedruckt werden?"
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
End If
If DruckerNr > n OR DruckerNr < 1 then DruckerNr = ""
If DruckerNr = "" then WSHShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
If DruckerNr = "" then WScript.Quit
n = 0
' gewählten Drucker ermitteln
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i+1)
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i )
End If
End If
Next
End Function ' Druckerauswahl
'***************************************************************
#########################################################################
>>> druckerliste.vbs <<<
'v4.7********************************************************
' File: DruckerListe.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle Drucker, die am Computer definiert sind
'************************************************************
Option Explicit
Dim n, i, Text, TextX
Dim WSHShell, WSHNet, NetPRN, fso
Dim ObjReg, ObjRemote, KeyX, Rootkey, oVal
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
If (fso.FileExists("REGOBJ.DLL")) Then ' Regobj.dll registrieren (erfordert AdminRechte)
Text = "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" ' damit läßt sich besser auf die registry zugreifen
WshShell.Run (Text),,TRUE ' muß im gleichen Verzeichnis wie das Script stehen
Set ObjReg = WScript.CreateObject("RegObj.Registry")
Else
MsgBox "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" & vbTab & " konnte nicht aufgerufen werden!", , WScript.ScriptName
WScript.Quit
End If
Set ObjRemote = objReg.RemoteRegistry(wshnet.ComputerName) ' Objekt zeigt auf aktuellen PC (REGOBJ.DLL)
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion"
KeyX = "\HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows"
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
if oVal.Name = "Device" then TextX = oVal.Value & "Device"
Next
On Error GoTo 0
Text = ""
For i = 0 To NetPRN.Count-1 Step 2
Text = Text & vbCRLF & vbTab & "Dr." & (i+2)/2 & vbTab & NetPRN(i) & vbTab & NetPRN(i+1)
If InStr( TextX, NetPRN(i) ) then Text = Text & vbCRLF & "==>" & vbTab & "Dr." & (i+2)/2 & " ist der Standarddrucker."
Next
MsgBox Text, , WScript.ScriptName
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
WScript.Quit
#########################################################################
>>> emailausad.vbs <<<
'*** v?.? *** www.dieseyer.de ******************************
'
' Datei: emailausad.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ermittel zu einem AD-Objekt (User) die hinterlegte
' Email-Adr.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim User, Tst
User = "dsey-er"
Tst = EmailAdrAusUserID( User )
MsgBox Tst, , "22 :: "
WScript.Quit
'*** v10.9 *** www.dieseyer.de *****************************
Function EmailAdrAusUserID( UserID )
'***********************************************************
' http://gallery.technet.microsoft.com/ScriptCenter/en-us/2809b510-5589-4764-9966-c69d20144bdf
Const xLDAP = "LDAP://DC=emea,DC=corpdir,DC=net"
Dim cnn : Set cnn = CreateObject("ADODB.Connection")
Dim sqlCMD : Set sqlCMD = CreateObject("ADODB.Command")
cnn.Provider = "ADsDSOObject"
' AccessUser = "[DOMAIN]\[USERNAME]"
' AccessPwd = "[PASSWORD]"
' cnn.Open "Active Directory Provider" ', AccessUser, AccessPwd
cnn.Open "Active Directory Provider"
sqlCMD.ActiveConnection = cnn
sqlCMD.CommandText = "SELECT Name, Mail FROM '" & xLDAP & "' WHERE objectClass='User' AND samAccountName='" & UserID & "'"
Dim rs : Set rs = sqlCMD.Execute
On Error Resume Next
EmailAdrAusUserID = rs.Fields("Mail").Value
End Function ' EmailAdrAusUserID( UserID )
#########################################################################
>>> emailsenden.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
'
' Datei: emailsenden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt
' ...Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim EmailTo : EmailTo = "nichtverwendet@gmx.de"
Dim EmailFrom : EmailFrom = EmailTo
Dim UserName : UserName = EmailTo
Dim UserPwd : UserPwd = "PwdIstGeheim!"
Dim SMTPServer : SMTPServer = "smtp.1und1.de"
: SMTPServer = "mail.gmx.net"
Dim Betreff : Betreff = "Email per SMTP mit Login"
Dim Text : Text = "Ich hoffe, das VBS packt das . . . von " & CreateObject("WScript.Network").ComputerName
Dim Anhang : Anhang = WScript.ScriptFullName ' als Anhang dieses VBS
: Anhang = "" ' kein Anhang'
EmailSenden SMTPServer, EmailFrom, EmailTo, UserName, UserPwd, Betreff, Text, Anhang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Popup "EMail versendet an " & vbCRLF & vbCRLF & vbTab & EmailTo, 7, "31 :: " & WScript.ScriptName, vbInformation
WScript.Quit
'*** v9.A *** www.dieseyer.de ******************************
Sub EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'***********************************************************
' Siehe http://www.microsoft.com/technet/scriptcenter/guide/sas_ent_wbpa.mspx?mfr=true
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt:
' .Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
' Sonst kommt:
' 550 must be authenticated
' 550 Need to authenticate
' Siehe http://msdn.microsoft.com/en-us/library/ms526318%28EXCHG.10%29.aspx
Dim Tst
Dim objEmail : Set objEmail = CreateObject("CDO.Message")
objEmail.From = EmailVon
objEmail.To = EmailAn
' objEmail.Cc = EmailAn
' objEmail.Bcc = EmailAn
objEmail.Subject = Betreff
objEmail.Textbody = Text
If not Anhang = "" Then
objEmail.AddAttachment Anhang
End If
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = AnmName
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = AnmPassw
objEmail.Configuration.Fields.Update
On Error Resume Next
Tst = objEmail.Send
If err.Number <> 0 Then MsgBox err.Number & " - " & err.Description, , "70 :: " & WScript.ScriptName
End Sub ' EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
#########################################################################
>>> emailsenden_cmd.vbs <<<
'*** v10.B *** www.dieseyer.de *****************************
'
' Datei: emailsenden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt
' ...Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim EmailTo : EmailTo = "nichtverwendet@gmx.de"
Dim EmailFrom : EmailFrom = EmailTo
Dim UserName : UserName = EmailTo
Dim UserPwd : UserPwd = "PwdIstGeheim!"
Dim SMTPServer : SMTPServer = "smtp.1und1.de"
: SMTPServer = "mail.gmx.net"
Dim Betreff : Betreff = WScript.CreateObject("WScript.Network").ComputerName
Dim Text : Text = ""
Dim Anhang : Anhang = "" ' kein Anhang'
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Args : Set Args = Wscript.Arguments
Dim LogDatei : LogDatei = LogDateiFestlegenX64() ' Prozedur-Aufruf
Trace32Log "037 :: ", 1
Trace32Log "038 :: Start " & WScript.ScriptFullName & " ( Dateidatum: " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "039 :: LogDatei: " & LogDatei, 1
Trace32Log "040 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "041 :: Angemeldeter User: " & WSHNet.UserName, 1
For i = 0 to Args.Count - 1 ' hole alle Argumente
Text = Text & " " & Trim( Args( i ) )
Next
Trace32Log "046 :: Erhaltenes Argument: '" & Text & "'", 1
EmailSenden SMTPServer, EmailFrom, EmailTo, UserName, UserPwd, Betreff, Text, Anhang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Popup "EMail versendet an " & vbCRLF & vbCRLF & vbTab & EmailTo, 7, "051 :: " & WScript.ScriptName, vbInformation
WScript.Quit
'*** v9.A *** www.dieseyer.de ******************************
Sub EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'***********************************************************
' Siehe http://www.microsoft.com/technet/scriptcenter/guide/sas_ent_wbpa.mspx?mfr=true
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt:
' .Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
' Sonst kommt:
' 550 must be authenticated
' 550 Need to authenticate
' Siehe http://msdn.microsoft.com/en-us/library/ms526318%28EXCHG.10%29.aspx
Dim Tst
Dim objEmail : Set objEmail = CreateObject("CDO.Message")
objEmail.From = EmailVon
objEmail.To = EmailAn
' objEmail.Cc = EmailAn
' objEmail.Bcc = EmailAn
objEmail.Subject = Betreff
objEmail.Textbody = Text
If not Anhang = "" Then
objEmail.AddAttachment Anhang
End If
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = AnmName
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = AnmPassw
objEmail.Configuration.Fields.Update
On Error Resume Next
Tst = objEmail.Send
If err.Number <> 0 Then MsgBox err.Number & " - " & err.Description, , "090 :: " & WScript.ScriptName
End Sub ' EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'************************************************************
Function LogDateiFestlegenX64()
'************************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = WScript.FullName ' ergibt C:\WINDOWS\system32\wscript.exe
Txt = Mid( Txt, 1, InStrRev( Txt, "\" ) - 1 ) ' ergibt C:\WINDOWS\system32
Tst = Mid( Txt, 1, InStrRev( Txt, "\" ) - 1 ) & "\SysWOW64" ' ergibt C:\WINDOWS\SysWOW64
If fso.FolderExists( Tst ) Then Txt = Tst ' : MsgBox Txt & vbCRLF & Tst, , "106 :: "
Txt = Txt & "\CCM" ' ergibt C:\WINDOWS\sysWOW64\CCM\ oder C:\WINDOWS\system32\CCM\
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
Txt = Txt & "\Inst.Log" ' ergibt C:\WINDOWS\sysWOW64\CCM\Inst.Log\ oder C:\WINDOWS\system32\CCM\Inst.Log\
If not fso.FolderExists( Txt ) Then fso.CreateFolder( Txt )
Txt = Txt & "\" & WScript.ScriptName ' ergibt ..\CCM\Inst.Log\....vbs"
Txt = Mid( Txt, 1, InStrRev( Txt, "." ) ) ' ergibt ..\CCM\Inst.Log\...."
Txt = Txt & "log" ' ergibt ..\CCM\Inst.Log\....log"
LogDateiFestlegenX64 = Txt
End Function ' LogDateiFestlegenX64()
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "203 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "204 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> erinnerung.vbs <<<
'v4.A*****************************************************
' File: erinnerung.vbs
' Autor: Zuujin@web.de
' http://source-center.de/forum/member.php?u=1294
'
' http://dieseyer.de
'
' Erstellt mit Datum/Zeit eine versteckte "C:\Erinnerung.txt"
' und setzt in der Egistry "/All Users/.../Autostart/" einen
' Eintrag, damits beim nächsten systemstart das Skript
' (versteckt) wieder anläuft (und die .txt ausliest) . . .
' bis die Zeit REIF ist
'*********************************************************
set fso = CreateObject ("scripting.filesystemobject")
set sho = CreateObject ("wscript.shell")
Wert = False
IF NOT fso.FileExists ("C:\Erinnerung.txt") THEN
Heute = msgbox ("Würde die Erinnerung am heutigen Tag stattfinden?",vbyesno or vbquestion,"Erinnerung heute?")
IF Heute = vbyes THEN
input = inputbox ("Bitte geben sie die Uhrzeit ein, zu der sie erinnert werden möchten:"&vbcr &" Schema: HH:MM:SS","Wann?",Time)
IF IsEmpty (input) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
MsgInput = inputbox ("An was wollen sie erinnert werden?","Was?")
IF IsEmpty (MsgInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
msgbox "Erinnerung gesetzt!",vbinformation,"Timer gestartet!"
DO
Zeit = time
input = CDate (input)
IF Zeit > input THEN
msgbox MsgInput,vbexclamation,"Erinnerung!"
Wert = True
END IF
wscript.sleep 500
LOOP UNTIL Wert = True
END IF
END IF
' ==============
' = MIT DATUM =
' ==============
ELSE
DateInput = inputbox ("Bitte geben sie das Datum ein, zu dem sie erinnert werden möchten:"&vbcr &" Schema: DD.MM.JJJJ","Wann?",Date)
IF IsEmpty (DateInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
TimeInput = inputbox ("Bitte geben sie die Uhrzeit ein, zu der sie erinnert werden möchten:"&vbcr &" Schema: HH:MM:SS","Wann?",Time)
IF IsEmpty (TimeInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
MsgInput = inputbox ("An was wollen sie erinnert werden?","Was?")
IF IsEmpty (MsgInput) THEN
msgbox "Keine Eingabe erfolgt. Programm beendet!",vbinformation,"Programmende!"
ELSE
Set File = fso.CreateTextFile ("C:\Erinnerung.txt")
File.writeline (DateInput)
File.writeline (TimeInput)
File.writeline (MsgInput)
File.close
Set RemFile = fso.getfile ("C:\Erinnerung.txt")
RemFile.attributes = RemFile.Attributes +2
Scriptpath = WScript.ScriptFullname
Set Script = fso.GetFile (Scriptpath)
Script.copy ("C:\Dokumente und Einstellungen\All Users\Startmenü\Programme\Autostart\Erinnerung.vbs ")
msgbox "Erinnerung gesetzt!",vbinformation,"Timer gestartet!"
DO
Jetzt = now
input = DateInput &" " &TimeInput
input = CDate (input)
IF Jetzt > input THEN
msgbox MsgInput,vbexclamation,"Erinnerung!"
Wert = True
RemFile.delete
END IF
wscript.sleep 500
LOOP UNTIL Wert = True
END IF
END IF
END IF
END IF
'================
'= NACH NEUSTART =
'================
ELSE
Const ForReading = 1
Set TXTFile = fso.OpenTextFile ("C:\Erinnerung.txt", ForReading)
DateInput = TXTFile.readline
TimeInput = TXTFile.readline
MsgInput = TXTFile.readline
TXTFile.close
DO
Jetzt = now
input = DateInput &" " &TimeInput
input = CDate (input)
IF Jetzt > input THEN
msgbox MsgInput,vbexclamation,"Erinnerung!"
Wert = True
Set RemFile = fso.getfile ("C:\Erinnerung.txt")
Set Script = fso.getfile ("C:\Dokumente und Einstellungen\All Users\Startmenü\Programme\Autostart\Erinnerung.vbs ")
RemFile.delete
Script.delete
END IF
wscript.sleep 500
LOOP UNTIL Wert = True
END IF
#########################################################################
>>> eventlog-bluescreen.vbs <<<
'v4.5*****************************************************
' File: eventlog-bluescreen.vbs
' (aus DateiZeilenweiseLesenBearbeitenSchreiben.vbs )
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' BlueScreens stehen nicht im Eventlog. Um zu sehen, wie oft
' es mögicherweise eine gegeben hat, kann man auswerten, wie
' oft die EventID 6006 (Shutdown) fehlt.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Txt, i, oArgs
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = oArgs.item(i)
If not fso.FileExists( Datei ) then
' MsgBox UCase( Datei ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
' WScript.Quit
End If
Exit For ' nur das erste Argument reicht
Next
' Gibt's keinen Dateinamen, wird das Skript beendet
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then
MsgBox "Datei auf das Skript ziehen und fallen lassen." & vbCRLF & vbCRLF & vbTab & " Das ist das Ende", , WScript.ScriptName
WScript.Quit
End If
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
Datei = fso.GetParentFolderName( WScript.ScriptFullName ) & "\" & fso.GetBaseName( Datei ) & "-.txt"
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' alle Zeilen lesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i= 1
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
Txt = FileIn.ReadLine
Txt = Replace( Txt, ".04 " , ".04 " )
Txt = Replace( Txt, " EventLog Informationen --- " , " " )
Txt = Replace( Txt, " --- " , " " )
If Instr( Txt, "6005") Then FileOut.WriteLine( "+ " & Txt & vbTab & i ) : i = i + 1
If Instr( Txt, "6006") Then FileOut.WriteLine( "- " & Txt )
' If Instr( Txt, "6009") Then FileOut.WriteLine( Txt )
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepade) beendet ist
' (Ziel-) Datei löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile( Datei )
#########################################################################
>>> eventlog.vbs <<<
'*** v9.9 *** www.dieseyer.de ******************************
'
' Datei: eventlog.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Den Abarbeitungsstatus eines Skripts kann man mit einem
' Einzeiler oder mit der Prozedur 'AnwendungEreignisInEventLog'
' in die Ereignisanzeige (Eventlog) Anwendungen (Application)
' schreiben.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst
Tst = WSCript.ScriptName & " wurde gestartet . . . "
AnwendungEreignisInEventLog 0, Tst
WScript.Sleep 2*1000
WScript.CreateObject("WScript.Shell").LogEvent 2, "Das geht auch in einer Zeile!"
Tst = WSCript.ScriptName & " wird jetzt beendet."
AnwendungEreignisInEventLog 4, Tst
WScript.Quit
'*** v9.9 *** www.dieseyer.de ******************************
Sub AnwendungEreignisInEventLog( EventType, Txt )
'***********************************************************
' Mögliche Werte für den EventType:
' 0 SUCCESS
' 1 ERROR
' 2 WARNING
' 4 INFORMATION
' 8 AUDIT_SUCCESS
' 16 AUDIT_FAILURE
WScript.CreateObject("WScript.Shell").LogEvent EventType, Txt
End Sub ' AnwendungEreignisInEventLog( EventType, Txt )
#########################################################################
>>> exec-hidden-plus.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' File: exec-hidden-plus.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Die ExecHiddenPlus-Function ruft ein weiteres Skript (das
' notfals neu geschrieben wird) auf, welches die Ausgaben
' von Befehlszeilen-Programme (mit DOS-Box) sammelt
'
'***********************************************************
Option Explicit
' zum Test die nächsten drei Zeilen frei geben
' Dim Tmp
' Tmp = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
MsgBox ExecHiddenPlus ( "%comspec% /c ipconfig /all" ), , "20 :: " & WScript.ScriptName
MsgBox ExecHiddenPlus ( "%comspec% /c Ping 127.0.0.1 -n 1" ), , "21 :: " & WScript.ScriptName
WScript.Quit
'*** v9.4 *** www.dieseyer.de ******************************
Function ExecHiddenPlus( CMD )
'***********************************************************
Dim FileOut, oWsh, Tmp
Tmp = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
If CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
CreateObject("Scripting.FileSystemObject").DeleteFile Tmp, True
End If
If not CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
' zum Test nächste Zeile frei geben
' MsgBox Tmp & vbCRLF & vbCRLF & "F E H L T und wird deshalb neu geschrieben.", , "40 :: " & Titel
Set FileOut = CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = """" " )
FileOut.WriteLine( " set oArgs = Wscript.Arguments " )
FileOut.WriteLine( " For i = 0 to oArgs.Count - 1 " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox oArgs.item(i) , , WScript.ScriptName & "" - oArgs "" " )
FileOut.WriteLine( " if Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & """""""" & oArgs.item(i) & """""""" & "" "" " )
FileOut.WriteLine( " if not Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & oArgs.item(i) & "" "" " )
FileOut.WriteLine( " Next " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox CMD , , WScript.ScriptName & "" Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec( CMD ) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ), , WScript.ScriptName & "" Ende "" " )
FileOut.Close
Set FileOuT = nothing
End If
Set oWsh = CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp & " " & CMD , 0, true
ExecHiddenPlus = oWsh.Environment("Volatile")( "Ergebnis" )
' zum Test nächste Zeile frei geben - Löschen der 'Tmp-Datei
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHiddenPlus( CMD )
#########################################################################
>>> exec-hidden.vbs <<<
'v3.A*****************************************************
' File: exec-hidden.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Die ExecHide-Function ruft ein weiteres Skript (das
' notfals neu geschrieben wird) auf, welches die Ausgaben
' von Befehlszeilen-Programme (mit DOS-Box) sammelt
'*********************************************************
Option Explicit
MsgBox ExecHide ( "%comspec% /c ""C:\PROGRAM FILES\PINGi.EXE"" 127.0.0.1 -n 1" ), , WScript.ScriptName
MsgBox ExecHide ( "%comspec% /c Ping RS6663 -n 1" ), , WScript.ScriptName
WScript.Quit
'**************************************************************
Function ExecHidden ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
Dim FileOut, oWsh, Tmp
CMD = Replace( CMD, """", """""" )
Tmp = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHidden.VBS"
Set FileOut = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox """ & CMD & """ , , WScript.ScriptName & "" - Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec(""" & CMD & """) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ), , WScript.ScriptName & "" - Ende "" " )
FileOut.Close
Set FileOuT = nothing
Set oWsh = WScript.CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp , 0, true
ExecHidden = oWsh.Environment("volatile")( "Eregbnis" )
' zum Löschen der 'Tmp-Datei nächste Zeile frei geben
WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHidden ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
#########################################################################
>>> exec-test.vbs <<<
'v3.A***************************************************
' File: exec-test.vbs
' Autor: dieseyer.de
' dieseyer.de
'
'
'*******************************************************
Option Explicit
Dim WSHShell, fso, FileOut
Dim oExec
Dim input, inputX, i, x, NeueZeit
Dim BatDatei
Dim FSO_PP, FileOut_PP, VBSDatei_PP, Prog_PP
Set Prog_PP = nothing
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
Set WSHShell = WScript.CreateObject("WScript.Shell")
BatDatei = "exec-tst.bat"
DateiErstellen BatDatei ' Function DateiErstellen - Aufruf
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Set oExec = WshShell.Exec( BatDatei )
' Set oExec = WshShell.Exec("%comspec% /c " & BatDatei )
' Set oExec = WshShell.Exec("%comspec% /k " & BatDatei )
Set oExec = WshShell.Exec("%comspec% /c " & BatDatei )
' Start der Anwendung mit der WSHShell.Exec-Methode
i = -1
i = +1
NeueZeit = Hour( DateAdd("h", i, time() ) )
NeueZeit = NeueZeit & ":" & Minute( DateAdd("h", i, time() ) )
' errechnen einer neuen Zeit
' NeueZeit = "8:21"
PopsUp NeueZeit, 20 ' Function PopsUp - Aufruf
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do While True
If Not oExec.StdOut.AtEndOfStream Then
input = input & oExec.StdOut.Read(1)
' Einlesen der Ausgaben der mit der WSHShell.Exec-Methode
' gestarteten Anwendung
If InStr(input, "eben Sie die neue Zeit ein:") <> 0 Then Exit Do
' enthalten die gelesenen Zeichen . . .
' BatDatei hat den 'time'-Befehl ausgeführt
End If
' WScript.Sleep 3
Loop
oExec.StdIn.Write NeueZeit
' übereben der neuen Zeit an die Anwendung, die mit
' der mit der WSHShell.Exec-Methode gestartet wurde
' (es wird automatisch [Enter] mit übergeben)
' (Antwort auf den 'time'-Befehl in der BatDatei)
WScript.Sleep 250
PopsUp "1. Do .. Loop erledigt" & vbCRLF & NeueZeit , 20
WScript.Sleep 300
inputX = ""
Do While True
If Not oExec.StdOut.AtEndOfStream Then
inputX = inputX & oExec.StdOut.Read(1)
' Einlesen der Ausgaben der mit der WSHShell.Exec-Methode
' gestarteten Anwendung
If InStr(inputX, ". . . ") <> 0 Then Exit Do
' enthalten die gelesenen Zeichen . . .
' BatDatei hat den 'pause'-Befehl ausgeführt
End If
Loop
input = input & inputX
PopsUp "2. Do .. Loop erledigt" , 20
' oExec.StdIn.Write VbCrLf
oExec.StdIn.Write "a"
' Antwort auf 'Press any Key . . . '
' (Antwort auf den 'pause'-Befehl in der BatDatei)
inputX = ""
Do While True
If Not oExec.StdOut.AtEndOfStream Then
inputX = inputX & oExec.StdOut.Read(1)
' Einlesen der Ausgaben der mit der WSHShell.Exec-Methode
' gestarteten Anwendung
If InStr(inputX, "- Ende") <> 0 Then Exit Do
' enthalten die gelesenen Zeichen . . .
' BatDatei hat den 'echo ... - Ende'-Befehl ausgeführt
End If
Loop
input = input & inputX
PopsUp "3. Do .. Loop erledigt" , 20
PopsUp "Skript erledigt" , 10
MsgBox vbCRLF & input , , WScript.ScriptName
' **************************************************************
Function PopsUp ( TxT, Dauer ) ' Aufruf v3.7 - http://dieseyer.de
' **************************************************************
' ACHTUNG! Ausserhalb und ver dem ersten Aufruf dieser Prozedur
' muss einmal "Set Prog_PP = nothing" stehen, sonst wird es
' mit dem "prog.terminate" innerhalb der Prozedur nichts!
'
' ACHTUNG! Alle Variablen müssen ausserhalb dieser Prozedur
' deklariert werden (also folgende Zeilen an den Skript-Anafng):
' Dim FSO_PP, FileOut_PP, VBSDatei_PP, Prog_PP
' Set Prog_PP = nothing
'
' Die Vorversion hat (versucht) das PopUp über AppActivate
' zu schließen.
Set Fso_PP = CreateObject("Scripting.FileSystemObject")
' VBSDatei_PP = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
VBSDatei_PP = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
On Error Resume Next
Prog_PP.terminate
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
If Txt = "" then
' On Error Resume Next
IF Fso_PP.FileExists(VBSDatei_PP) then Fso_PP.DeleteFile(VBSDatei_PP) ' löscht das MSG-VBScript
' On Error GoTo 0
Exit Function
End If
Txt = Replace( Txt, vbCRLF, """ & vbCRLF & """ )
Set FileOut_PP = Fso_PP.OpenTextFile(VBSDatei_PP, 2, true) ' MSG-VBScript öffnen mit neu anlegen
FileOut_PP.WriteLine "WScript.CreateObject(""WScript.Shell"").Popup """ & Txt & """ , " & Dauer & ", """ & Fso_PP.GetFileName( VBSDatei_PP ) & " "" "
FileOut_PP.Close
Set FileOut_PP = Nothing
Set Prog_PP = createObject("WScript.Shell").exec( "WScript " & VBSDatei_PP )
Set Fso_PP = Nothing
End Function ' PopsUp v3.7 - http://dieseyer.de
' **************************************************************
' **************************************************************
Function DateiErstellen ( Datei ) ' Aufruf
' **************************************************************
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
FileOut.WriteLine( "time " )
' 1. Do .. Loop - Schleife liest die Ausgaben von "time" aus
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@echo ""doll"" " )
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@echo COMSPEC steht auf: %comspec% " )
FileOut.WriteLine( "dir c:\pr*.* /b " )
FileOut.WriteLine( "@ping 127.0.0.1" )
FileOut.WriteLine( "@echo. " )
FileOut.WriteLine( "@echo X = = = X " )
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@pause" )
' 2. Do .. Loop - Schleife liest die Ausgaben BIS "pause" aus
FileOut.WriteLine( "@echo." )
FileOut.WriteLine( "@echo %0 - Ende " )
' 3. Do .. Loop - Schleife liest die Ausgaben BIS zu den
' Ausgaben von "@echo %0 - Ende" aus
FileOut.Close
Set FileOuT = nothing
End Function ' DateiErstellen ( BatDatei )
' **************************************************************
#########################################################################
>>> formatbytes.vbs <<<
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim m, t, x, i, k
m = 1
t = x = x : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1025 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024*1024 - 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024*1024 - 0 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
t = 1024*1024*1024*1024*1024 + 1 : x = x & FormatkMGTBytes( t, m ) & vbCRLF
' MsgBox x
x = "" : m = 3 : t = 390 : i = 1.5
Do
i = i * 1.01
t = t * i
k = t
k = FormatNumber( k, 0,0,0, -1)
x = x & FormatkMGTBytes( k, m ) & " " & vbTab & FormatNumber( t, 0,0,0, -1) & vbCRLF
If t > 1024*1024*1024*1024*64 Then Exit Do
Loop
MsgBox x, 4096, t
WScript.Quit
'***********************************************************
Function FormatkMGTBytes( n, i )
'***********************************************************
Dim Tyt
' if i > 1 Then i = i - 1
Tyt = " Byte"
If n > 10 Then Tyt = " Byte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " Byte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " kByte" : n = FormatNumber( n / 1024, i )
If n > 10 Then Tyt = " kByte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " kByte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " MByte" : n = FormatNumber( n / 1024, i )
If n > 10 Then Tyt = " MByte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " MByte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " GByte" : n = FormatNumber( n / 1024, i )
If n > 10 Then Tyt = " GByte" : n = FormatNumber( n , i - 1 )
If n > 100 Then Tyt = " GByte" : n = FormatNumber( n , i - 2 )
If n > 1024 Then Tyt = " TByte" : n = FormatNumber( n / 1024, i )
FormatkMGTBytes = n & Tyt
End Function ' FormatkMGTBytes( n, i )
#########################################################################
>>> fso-beispielcode.vbs <<<
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' FileSystemObject-Beispielcode
'
' Copyright 1998 Microsoft Corporation. Alle Rechte vorbehalten.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Informationen zur Codequalität:
'
' 1) Der folgende Code führt eine Anzahl von Zeichenfolgenmanipulationen
' aus. Dabei werden kurze Zeichenfolgen mit dem Operator "&" verkettet.
' Da Zeichenfolgenverkettungen lange dauern, ist dieser Code nicht sehr
' effizient. Es ist jedoch ein sehr gängiger Weg zum Schreiben von Code.
' Dieser Weg wird hier verwendet, da dieses Programm intensive Fest-
' plattenoperationen ausführt und diese Operationen wesentlich langsamer
' als die Operationen zum Verketten der Zeichenfolgen im Speicher sind.
' Beachten Sie auch, dass dieser Code zu Demonstrationszwecken geschrieben
' wurde.
'
' 2) Es wird "Option Explicit" verwendet, da der Zugriff auf deklarierte
' Variablen etwas schneller als der Zugriff auf undeklarierte Variablen
' ist. Außerdem wird so das Entstehen von Fehlern im Code verhindert,
' wie z. B. durch den Schreibfehler DriveTypeCDORM statt DriveTypeCDROM.
'
' 3) In diesem Code wurde keine Fehlerbehandlung vorgesehen. Der Code ist
' so besser lesbar. Obwohl Vorkehrungen zum Verhindern von Fehlern in
' normalen Fällen getroffen wurden, können sich Dateisysteme eventuell
' unvorhersehbar verhalten. In kommerziellem Code sollten Sie "On Error
' Resume Next" und das Err-Objekt verwenden, um mögliche Fehler abzufangen.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Einige hilfreiche globale Variablen
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Tabulator
Dim NeueZeile
Const TestLW = "C"
Const TestDateiPfad = "C:\Test"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Von Drive.DriveType zurückgegebene Konstanten
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const DriveTypeWechselbar = 1
Const DriveTypeFest = 2
Const DriveTypeNetzwerk = 3
Const DriveTypeCDROM = 4
Const DriveTypeRAMLW = 5
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Von File.Attributes zurückgegebene Konstanten
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const AttributNormal = 0
Const AttributSchreibgesch = 1
Const AttributVersteckt = 2
Const AttributSystem = 4
Const AttributDatentr = 8
Const AttributVerzeichnis = 16
Const AttributArchiv = 32
Const AttributAlias = 64
Const AttributKomprimiert = 128
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Konstanten zum Öffnen von Dateien
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const DateiOeffnenZumLesen = 1
Const DateiOeffnenZumSchreiben = 2
Const DateiOeffnenZumAnfuegen = 8
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ZeigeLWTyp
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den Laufwerktyp eines angegebenen Drive-Objekts beschreibt.
'
' Zeigt Folgendes
'
' - Drive.DriveType
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ZeigeLWTyp(LW)
Dim S
Select Case LW.DriveType
Case DriveTypeWechselbar
S = "Wechselmedium"
Case DriveTypeFest
S = "Fest"
Case DriveTypeNetzwerk
S = "Netzwerk"
Case DriveTypeCDROM
S = "CD-ROM"
Case DriveTypeRAMLW
S = "RAM-Laufwerk"
Case Else
S = "Unbekannt"
End Select
ZeigeLWTyp = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ZeigeDateiAttribute
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die Datei- oder Ordnerattribute beschreibt.
'
' Zeigt Folgendes
'
' - File.Attributes
' - Folder.Attributes
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ZeigeDateiAttribute(Datei) ' Datei kann Datei oder Ordner sein
Dim S
Dim Attr
Attr = Datei.Attributes
If Attr = 0 Then
ZeigeDateiAttribute = "Normal"
Exit Function
End If
If Attr And AttributVerzeichnis Then S = S & "Verzeichnis "
If Attr And AttributSchreibgesch Then S = S & "Schreibgeschützt "
If Attr And AttributVersteckt Then S = S & "Versteckt "
If Attr And AttributSystem Then S = S & "System "
If Attr And AttributDatentr Then S = S & "Datenträger "
If Attr And AttributArchiv Then S = S & "Archiv "
If Attr And AttributAlias Then S = S & "Alias "
If Attr And AttributKomprimiert Then S = S & "Komprimiert "
ZeigeDateiAttribute = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeLWInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status der verfügbaren Laufwerke beschreibt.
'
' Zeigt Folgendes
'
' - FileSystemObject.Drives
' - Iteration der Drives-Auflistung
' - Drives.Count
' - Drive.AvailableSpace
' - Drive.DriveLetter
' - Drive.DriveType
' - Drive.FileSystem
' - Drive.FreeSpace
' - Drive.IsReady
' - Drive.Path
' - Drive.SerialNumber
' - Drive.ShareName
' - Drive.TotalSize
' - Drive.VolumeName
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeLWInformation(FSO)
Dim LWs
Dim LW
Dim S
Set LWs = FSO.Drives
S = "Anzahl der Laufwerke:" & Tabulator & LWs.Count & NeueZeile & NeueZeile
' Erstellt die erste Zeile des Berichts.
S = S & String(2, Tabulator) & "Laufwerk"
S = S & String(3, Tabulator) & "Datei"
S = S & Tabulator & "Gesamt"
S = S & Tabulator & "Frei"
S = S & Tabulator & "Verfügbar"
S = S & Tabulator & "Seriennummer" & NeueZeile
' Erstellt die zweite Zeile des Berichts.
S = S & "Laufwerkbuchstabe"
S = S & Tabulator & "Pfad"
S = S & Tabulator & "Typ"
S = S & Tabulator & "Bereit?"
S = S & Tabulator & "Name"
S = S & Tabulator & "System"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Speicherplatz"
S = S & Tabulator & "Nummer" & NeueZeile
' Trennlinie.
S = S & String(105, "-") & NeueZeile
For Each LW In LWs
S = S & LW.DriveLetter
S = S & Tabulator & LW.Path
S = S & Tabulator & ZeigeLWTyp(LW)
S = S & Tabulator & LW.IsReady
If LW.IsReady Then
If DriveTypeNetzwerk = LW.DriveType Then
S = S & Tabulator & LW.ShareName
Else
S = S & Tabulator & LW.VolumeName
End If
S = S & Tabulator & LW.FileSystem
S = S & Tabulator & LW.TotalSize
S = S & Tabulator & LW.FreeSpace
S = S & Tabulator & LW.AvailableSpace
S = S & Tabulator & Hex(LW.SerialNumber)
End If
S = S & NeueZeile
Next
ErzeugeLWInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeDateiInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status einer Datei beschreibt.
'
' Zeigt Folgendes
'
' - File.Path
' - File.Name
' - File.Type
' - File.DateCreated
' - File.DateLastAccessed
' - File.DateLastModified
' - File.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeDateiInformation(Datei)
Dim S
S = NeueZeile & "Pfad:" & Tabulator & Datei.Path
S = S & NeueZeile & "Name:" & Tabulator & Datei.Name
S = S & NeueZeile & "Typ:" & Tabulator & Datei.Type
S = S & NeueZeile & "Attribute:" & Tabulator & ZeigeDateiAttribute(Datei)
S = S & NeueZeile & "Erstellt:" & Tabulator & Datei.DateCreated
S = S & NeueZeile & "Letzter Zugriff:" & Tabulator & Datei.DateLastAccessed
S = S & NeueZeile & "Letzte Änderung:" & Tabulator & Datei.DateLastModified
S = S & NeueZeile & "Größe" & Tabulator & Datei.Size & NeueZeile
ErzeugeDateiInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeOrdnerInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status eines Ordners beschreibt.
'
' Zeigt Folgendes
'
' - Folder.Path
' - Folder.Name
' - Folder.DateCreated
' - Folder.DateLastAccessed
' - Folder.DateLastModified
' - Folder.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeOrdnerInformation(Ordner)
Dim S
S = "Pfad:" & Tabulator & Ordner.Path
S = S & NeueZeile & "Name:" & Tabulator & Ordner.Name
S = S & NeueZeile & "Attribute:" & Tabulator & ZeigeDateiAttribute(Ordner)
S = S & NeueZeile & "Erstellt:" & Tabulator & Ordner.DateCreated
S = S & NeueZeile & "Letzter Zugriff:" & Tabulator & Ordner.DateLastAccessed
S = S & NeueZeile & "Letzte Änderung:" & Tabulator & Ordner.DateLastModified
S = S & NeueZeile & "Größe:" & Tabulator & Ordner.Size & NeueZeile
ErzeugeOrdnerInformation = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeAlleOrdnerInformationen
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status eines Ordners
' und all seiner Dateien und untergeordneten Ordner beschreibt.
'
' Zeigt Folgendes
'
' - Folder.Path
' - Folder.SubFolders
' - Folders.Count
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeAlleOrdnerInformationen(Ordner)
Dim S
Dim UnterOrdnerAuflistung
Dim UnterOrdner
Dim Dateien
Dim Datei
S = "Ordner:" & Tabulator & Ordner.Path & NeueZeile & NeueZeile
Set Dateien = Ordner.Files
If 1 = Dateien.Count Then
S = S & "Es ist 1 Datei vorhanden" & NeueZeile
Else
S = S & "Es sind " & Dateien.Count & "Dateien vorhanden" & NeueZeile
End If
If Dateien.Count <> 0 Then
For Each Datei In Dateien
S = S & ErzeugeDateiInformation(Datei)
Next
End If
Set UnterOrdnerAuflistung = Ordner.SubFolders
If 1 = UnterOrdnerAuflistung.Count Then
S = S & NeueZeile & "Es ist 1 Unterordner vorhanden" & NeueZeile & NeueZeile
Else
S = S & NeueZeile & "Es sind" & UnterOrdnerAuflistung.Count & "Unterordner vorhanden" & NeueZeile & NeueZeile
End If
If UnterOrdnerAuflistung.Count <> 0 Then
For Each UnterOrdner In UnterOrdnerAuflistung
S = S & ErzeugeOrdnerInformation(UnterOrdner)
Next
S = S & NeueZeile
For Each UnterOrdner In UnterOrdnerAuflistung
S = S & ErzeugeAlleOrdnerInformationen(UnterOrdner)
Next
End If
ErzeugeAlleOrdnerInformationen = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeTestInformation
'
' Zweck:
'
' Erstellt eine Zeichenfolge, die den aktuellen Status des Ordners C:\Test
' und all seiner Dateien und untergeordneten Ordner beschreibt.
'
' Zeigt Folgendes
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.GetFolder
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeTestInformation(FSO)
Dim TestOrdner
Dim S
If Not FSO.DriveExists(TestLW) Then Exit Function
If Not FSO.FolderExists(TestDateiPfad) Then Exit Function
Set TestOrdner = FSO.GetFolder(TestDateiPfad)
ErzeugeTestInformation = ErzeugeAlleOrdnerInformationen(TestOrdner)
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' LoescheTestVerzeichnis
'
' Zweck:
'
' Bereinigt das Testverzeichnis.
'
' Zeigt Folgendes
'
' - FileSystemObject.GetFolder
' - FileSystemObject.DeleteFile
' - FileSystemObject.DeleteFolder
' - Folder.Delete
' - File.Delete
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub LoescheTestVerzeichnis(FSO)
Dim TestOrdner
Dim UnterOrdner
Dim Datei
' Zwei Möglichkeiten, eine Datei zu löschen:
FSO.DeleteFile(TestDateiPfad & "\Beatles\OctopusGarden.txt")
Set Datei = FSO.GetFile(TestDateiPfad & "\Beatles\BathroomWindow.txt")
Datei.Delete
' Zwei Möglichkeiten, einen Ordner zu löschen:
FSO.DeleteFolder(TestDateiPfad & "\Beatles")
FSO.DeleteFile(TestDateiPfad & "\Liesmich.txt")
Set TestOrdner = FSO.GetFolder(TestDateiPfad)
TestOrdner.Delete
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeLiedText
'
' Zweck:
'
' Erstellt mehrere Textdateien in einem Ordner.
'
'
' Zeigt Folgendes
'
' - FileSystemObject.CreateTextFile
' - TextStream.writeLine
' - TextStream.write
' - TextStream.writeBlankLines
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ErzeugeLiedText(Ordner)
Dim TextStream
Set TextStream = Ordner.CreateTextFile("OctopusGarden.txt")
TextStream.write("Octopus' Garden") ' Beachten Sie, dass der Datei kein Zeilenvorschub hinzugefügt wird.
TextStream.WriteLine("(von Ringo Starr)")
TextStream.writeBlankLines(1)
TextStream.writeLine("I'd like to be under the sea, in an octopus' garden in the shade,")
TextStream.writeLine("He'd let us in, knows where we've been - in his octopus' garden in the shade.")
TextStream.writeBlankLines(2)
TextStream.Close
Set TextStream = Ordner.CreateTextFile("BathroomWindow.txt")
TextStream.writeLine("She Came In Through The Bathroom Window (von Lennon/McCartney)")
TextStream.writeLine("")
TextStream.writeLine("She came in through the bathroom window, protected by a silver spoon")
TextStream.writeLine("But now she sucks her thumb and wanders by the banks of her own lagoon")
TextStream.writeBlankLines(2)
TextStream.Close
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' HoleLiedText
'
' Zweck:
'
' Zeigt den Inhalt der Liedtexte an.
'
'
' Zeigt Folgendes
'
' - FileSystemObject.OpenTextFile
' - FileSystemObject.GetFile
' - TextStream.ReadAll
' - TextStream.Close
' - File.OpenAsTextStream
' - TextStream.AtEndOfStream
' - TextStream.ReadLine
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function HoleLiedText(FSO)
Dim TextStream
Dim S
Dim Datei
' Es gibt verschiedene Möglichkeiten, eine Textdatei zu öffnen und die
' Daten dieser Datei zu lesen. Hier sind zwei Möglichkeiten:
Set TextStream = FSO.OpenTextFile(TestDateiPfad & "\Beatles\OctopusGarden.txt", DateiOeffnenZumLesen)
S = TextStream.ReadAll & NeueZeile & NeueZeile
TextStream.Close
Set Datei = FSO.GetFile(TestDateiPfad & "\Beatles\BathroomWindow.txt")
Set TextStream = Datei.OpenAsTextStream(DateiOeffnenZumLesen)
Do While Not TextStream.AtEndOfStream
S = S & TextStream.ReadLine & NeueZeile
Loop
TextStream.Close
HoleLiedText = S
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ErzeugeTestVerzeichnis
'
' Zweck:
'
' Erstellt eine Verzeichnishierarchie, um das FileSystemObject-Objekt zu beschreiben.
'
' Die Hierarchie wird in dieser Reihenfolge erstellt:
'
' C:\Test
' C:\Test\Liesmich.txt
' C:\Test\Beatles
' C:\Test\Beatles\OctopusGarden.txt
' C:\Test\Beatles\BathroomWindow.txt
'
'
' Zeigt Folgendes
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.CreateFolder
' - FileSystemObject.CreateTextFile
' - Folders.Add
' - Folder.CreateTextFile
' - TextStream.writeLine
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ErzeugeTestVerzeichnis(FSO)
Dim TestOrdner
Dim UnterOrdnerAuflistung
Dim UnterOrdner
Dim TextStream
' Bricht ab, wenn (a) das Laufwerk nicht vorhanden oder (b) das zu erstellende Verzeichnis bereits
' vorhanden ist.
If Not FSO.DriveExists(TestLW) Then
ErzeugeTestVerzeichnis = False
Exit Function
End If
If FSO.FolderExists(TestDateiPfad) Then
ErzeugeTestVerzeichnis = False
Exit Function
End If
Set TestOrdner = FSO.CreateFolder(TestDateiPfad)
Set TextStream = FSO.CreateTextFile(TestDateiPfad & "\Liesmich.txt")
TextStream.writeLine("Meine Liedtextsammlung")
TextStream.Close
Set UnterOrdnerAuflistung = TestOrdner.SubFolders
Set UnterOrdner = UnterOrdnerAuflistung.Add("Beatles")
ErzeugeLiedText UnterOrdner
ErzeugeTestVerzeichnis = True
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Die Hauptroutine
'
' Zunächst wird ein Testverzeichnis mit einigen Unterordnern und Dateien erstellt.
' Anschließend werden Informationen über die verfügbaren Festplattenlaufwerke und
' über das Testverzeichnis ausgegeben und danach alles wieder entfernt.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Main
Dim FSO
' Einrichten globaler Daten.
Tabulator = Chr(9)
NeueZeile = Chr(10)
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not ErzeugeTestVerzeichnis(FSO) Then
Ausgabe "Testverzeichnis ist bereits vorhanden oder kann nicht erstellt werden. Fortsetzung nicht möglich."
Exit Sub
End If
Ausgabe ErzeugeLWInformation(FSO) & NeueZeile & NeueZeile
Ausgabe ErzeugeTestInformation(FSO) & NeueZeile & NeueZeile
Ausgabe HoleLiedText(FSO) & NeueZeile & NeueZeile
LoescheTestVerzeichnis(FSO)
End Sub
#########################################################################
>>> gmxautologin.vbs <<<
'v3.8***************************************************
' File: GmxAutologin.vbs
' Autor: ??? - PC-Welt 09/2003
' dieseyer.de
'
' Lädt im IE eine Site und übernimmt das Login.
'*******************************************************
Option Explicit
Dim Kennung, Passwort, EMailSite, Text
Dim MeinIE, READYSTATE_COMPLETE
Dim oDoc, oArea, oRng
EMailSite = "http://www.gmx.net"
Kennung = "username@gmx.de"
Passwort = "geheim"
Passwort = ""
If Passwort = "" then
Text = "Mit welchem Passwort soll der Account " & vbCRLF
Text = Text & vbTab & UCase(Kennung) & vbCRLF
Text = Text & "bei " & EMailSite & " geöffnet werden?"
If Passwort = "" then Passwort = InputBox (Text, WScript.ScriptName)
If Passwort = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Passwort = "" then WScript.Quit
End If
READYSTATE_COMPLETE = 4
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
Loop
Set oDoc = MeinIE.Document
oDoc.all.id.value = Kennung
oDoc.all.p.value = Passwort
oDoc.all.login.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
WScript.Quit
' Zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' IE: <input type="text" name="id" size="10" class="i10">
' VBS: oDoc.all.id.value = Kennung
' Funktion: Durch das VBS-Skript soll das Input-Feld für den Anmeldenamen
' (als 'Kennung' auf der HTML-Seite zu lesen) hat den (Variablen-)
' Namen 'id' (im HTML-Code) und soll den Inhalt (value; Wert)
' erhalten, der in der (Skript-) Variablen 'Kennung' steht.
' IE: <input type="password" name="p" size="10" class="i10">
' VBS: oDoc.all.p.value
' Funktion: Durch das VBScript-Skript soll das Input-Feld für das Passwort
' (als 'Passwort' auf der HTML-Seite zu lesen) hat den (Variablen-)
' Namen 'p' und soll den Inhalt (value; Wert) erhalten, der in der
' (Skript-) Variablen 'Passwort' steht.
' VBS: oDoc.all.login.Submit
' Funktion: werden die nunmehr getätigten Eingabe an das HTML-Formular übergeben
' (entspricht einem <Enter> bzw. einem Klick auf 'Login') und an den
' Server (bei gmx.net) gesendet.
#########################################################################
>>> gmxautologin2.vbs <<<
'v3.9**************************************************
' File: GmxAutologin2.vbs
' Autor: Raoul A.
' madraoul1@yahoo.de
' Lädt im IE eine Site und übernimmt das Login.
' Neue Funktion: Speichert Username und Kennwort
'******************************************************
Option Explicit
Dim Kennung, Passwort, EMailSite, Text ,Text2, Text3
Dim MeinIE, READYSTATE_COMPLETE
Dim oDoc, oArea, oRng
Dim FSO,f,TextStream, output, Dialog, raoul
Dim f1, create, output2, dialog2
Text = "Bitte Passwort eingaben! "
Text2 = "Bitte username eingeben!"
Text3 = "Bitte Email-Internetadresse eingeben!"
EMailSite = "www.gmx.de"
Kennung = ""
Passwort = ""
dialog = ""
Set FSO = CreateObject("Scripting.FileSystemObject")
f1 = ("C:\daten.txt")
if not FSO.FileExists(f1) then
set create = FSO.CreateTextFile("C:\daten.txt")
dialog = InputBox (Text2, WScript.ScriptName)
If dialog = "" then
WScript.echo "es wurde nichts eingegeben"
WScript.quit
End if
create.writeline(dialog)
dialog2 = InputBox (Text, WScript.ScriptName)
If dialog2 = "" then
WScript.echo "es wurde nichts eingegeben"
WScript.quit
End If
create.writeLine(dialog2)
create.Close
END if
Set TextStream = FSO.OpenTextFile("C:\daten.txt")
IF Kennung = "" then
output = TextStream.ReadLine()
Kennung = output
WScript.Echo "Username:"& Kennung
End if
Set raoul = FSO.OpenTextFile("C:\daten.txt")
IF Passwort = "" then
output2 = raoul.SkipLine() & raoul.ReadLine()
Passwort = output2
WScript.Echo "Passwort:"& Passwort
End if
READYSTATE_COMPLETE = 4
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
Loop
Set oDoc = MeinIE.Document
oDoc.all.id.value = Kennung
oDoc.all.p.value = Passwort
oDoc.all.login.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
#########################################################################
>>> gmxautologin2009.vbs <<<
'*** v9.B *** www.dieseyer.de ******************************
' File: GmxAutologin2009.vbs
' Autor: ??? - PC-Welt 09/2003
' dieseyer.de
'
' Lädt im IE eine Site und übernimmt das Login.
'
'***********************************************************
Option Explicit
Dim Kennung, Passwort, EMailSite, Text
Dim MeinIE
Dim oDoc, oArea, oRng
EMailSite = "http://www.gmx.net"
Kennung = "username@gmx.de"
Passwort = "Geheim!"
Passwort = ""
If Passwort = "" then
Text = "Mit welchem Passwort soll der Account " & vbCRLF
Text = Text & vbTab & UCase(Kennung) & vbCRLF
Text = Text & "bei " & EMailSite & " geöffnet werden?"
If Passwort = "" then Passwort = InputBox (Text, WScript.ScriptName)
If Passwort = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Passwort = "" then WScript.Quit
End If
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
WScript.Sleep 33
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Const READYSTATE_COMPLETE = 4
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
WScript.Sleep 33
Loop
Set oDoc = MeinIE.Document ' 2009
oDoc.all.username.value = Kennung
oDoc.all.password.value = Passwort
oDoc.all.inpLoginSubmit.value = "login"
oDoc.all.formLogin.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
WScript.Quit
' 2009 - zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' => <form id="formLogin" action="//service.gmx.net/de/cgi/login" method="post" name="login">
'
' <input name="AREA" value="1" type="hidden"/>
' <input name="EXT" value="redirect" type="hidden"/>
' <input name="EXT2" value="" type="hidden"/>
' <input name="uinguserid" value="" type="hidden"/>
' <fieldset id="fieldsetLoginUser">
' <label for="username"><span>E-Mail:</span></label>
' => <input name="id" id="username" class="field" type="text" value=""/>
' <label for="password"><span>Passwort:</span></label>
'
' => <input name="p" id="password" class="field" type="password" value=""/>
' <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' </fieldset>
' </form>
' IE2003: <input type="text" name="id" size="10" class="i10">
' IE2009: <input name="id" id="username" class="field" type="text" value=""/>
' VBS2003: oDoc.all.id.value = Kennung
' VBS2009: oDoc.all.username.value = Kennung
' Funktion: Das VBS trägt den Anmeldenamen ein: Das auszufüllende Feld (type="text")
' wird durch die ID (id="username") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Kennung' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Kennung
' IE2003: <input type="password" name="p" size="10" class="i10">
' IE2009: <input name="p" id="password" class="field" type="password" value=""/>
' VBS2003: oDoc.all.p.value
' VBS2009: oDoc.all.password.value
' Funktion: Das VBS trägt das Passwort ein: Das auszufüllende Feld (type="password")
' wird durch die ID (id="password") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Passwort' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Passwort
' IE2009: <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' VBS2003: oDoc.all.login.Submit
' VBS2009: oDoc.all.formLogin.Submit
' Funktion: Das VBS 'drückt' den [login]-Button: Anders als zunächst anzunehmen, muss
' NICHT <input> mit id="inpLoginSubmit" betätigt werden (Submit), sondern
' das Formular <form id="formLogin">: '
' oDoc.all.formLogin.Submit
#########################################################################
>>> gmxautologin2010.vbs <<<
'*** v10.1 *** www.dieseyer.de ******************************
' File: GmxAutologin2010.vbs
' Autor: ??? - PC-Welt 09/2003
' dieseyer.de
'
' Lädt im IE eine Site und übernimmt das Login.
'
'***********************************************************
Option Explicit
Dim Kennung, Passwort, EMailSite, Text
Dim MeinIE
Dim oDoc, oArea, oRng
EMailSite = "http://www.gmx.net"
Kennung = "username@gmx.de"
Passwort = "Geheim!"
Passwort = ""
If Passwort = "" then
Text = "Mit welchem Passwort soll der Account " & vbCRLF
Text = Text & vbTab & UCase(Kennung) & vbCRLF
Text = Text & "bei " & EMailSite & " geöffnet werden?"
If Passwort = "" then Passwort = InputBox (Text, WScript.ScriptName)
If Passwort = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Passwort = "" then WScript.Quit
End If
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
WScript.Sleep 33
Loop
MeinIE.Visible = 1
MeinIE.Navigate EMailSite
Const READYSTATE_COMPLETE = 4
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
WScript.Sleep 33
Loop
Set oDoc = MeinIE.Document ' 2010
oDoc.all.inpLoginFreemailUsername.value = Kennung
oDoc.all.inpLoginFreemailPassword.value = Passwort
oDoc.all.formLoginFreemail.Submit
Set oDoc = Nothing
Set oArea = Nothing
Set oRng = Nothing
WScript.Quit
' 2010 - zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' => <form id="formLoginFreemail" class="login" action="https://service.gmx.net/de/cgi/login" method="post">
' <fieldset>
' <legend>Login</legend>
' <input type="hidden" name="AREA" value="1"/>
' <input type="hidden" name="EXT" value="redirect"/>
' <input type="hidden" name="EXT2" value=""/>
' <input type="hidden" name="uinguserid" value="__uuid__"/>
' <input type="hidden" name="dlevel" value="c"/>
' <input type="text" class="field username" id="inpLoginFreemailUsername" name="id" value=""/>
' => <input type="password" class="field password" id="inpLoginFreemailPassword" name="p" value=""/>
' => <input type="submit" class="submit" value="Login"/>
' <ul>
' <li class="first"><a href="http://service.gmx.net/de/cgi/g.fcgi/login/lose/password">Passwort vergessen?</a></li>
' <li class="last"><a href="http://www.gmx.net/nossl/">Ohne SSL</a></li>
' </ul>
' </fieldset>
' </form>
' 2009 - zum Verständnis muss man sich den Quellcode der Startseite ansehen:
' => <form id="formLogin" action="//service.gmx.net/de/cgi/login" method="post" name="login">
'
' <input name="AREA" value="1" type="hidden"/>
' <input name="EXT" value="redirect" type="hidden"/>
' <input name="EXT2" value="" type="hidden"/>
' <input name="uinguserid" value="" type="hidden"/>
' <fieldset id="fieldsetLoginUser">
' <label for="username"><span>E-Mail:</span></label>
' => <input name="id" id="username" class="field" type="text" value=""/>
' <label for="password"><span>Passwort:</span></label>
'
' => <input name="p" id="password" class="field" type="password" value=""/>
' <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' </fieldset>
' </form>
' IE2003: <input type="text" name="id" size="10" class="i10">
' IE2009: <input name="id" id="username" class="field" type="text" value=""/>
' VBS2003: oDoc.all.id.value = Kennung
' VBS2009: oDoc.all.username.value = Kennung
' Funktion: Das VBS trägt den Anmeldenamen ein: Das auszufüllende Feld (type="text")
' wird durch die ID (id="username") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Kennung' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Kennung
' IE2003: <input type="password" name="p" size="10" class="i10">
' IE2009: <input name="p" id="password" class="field" type="password" value=""/>
' VBS2003: oDoc.all.p.value
' VBS2009: oDoc.all.password.value
' Funktion: Das VBS trägt das Passwort ein: Das auszufüllende Feld (type="password")
' wird durch die ID (id="password") identifiziert, in das der Inhalt der
' (Skript-) Variable 'Passwort' eingetragen wird - value="" erhält einen Wert
' oDoc.all.username.value = Passwort
' IE2009: <input id="inpLoginSubmit" class="submit more" type="submit" value="login"/>
' VBS2003: oDoc.all.login.Submit
' VBS2009: oDoc.all.formLogin.Submit
' Funktion: Das VBS 'drückt' den [login]-Button: Anders als zunächst anzunehmen, muss
' NICHT <input> mit id="inpLoginSubmit" betätigt werden (Submit), sondern
' das Formular <form id="formLogin">: '
' oDoc.all.formLogin.Submit
#########################################################################
>>> hardwareinventur.vbs <<<
'==========================================================================
' VBScript Source File -- Created with SAPIEN Technologies PrimalSCRIPT(TM)
'
' NAME: hardwareinventur.vbs
'
' AUTHOR: Janke,
' DATE : 17.06.2002
'
' COMMENT: Erstellt ein Harwareverzeichnis für die gesamte Domäne
'
' (Nicht von dieseyer@gmx.de geprüft; v3.9.)
'==========================================================================
'**[ DECLARATIONS ]************
CONST ForReading = 1
CONST ForWriting = 2
CONST DEV_ID = 0
CONST FSYS = 1
CONST DSIZE = 2
CONST FSPACE = 3
CONST USPACE = 4
Dim fso, f, fsox, fx, objXL, wmiPath
Dim computerIndex, wscr, adsi, intbutton, strStart
Dim inputFile, outputFile, objKill, strAction, strComplete
Dim strPC, intRow, strFilter, RowNum, strCompName
Dim strSN, strDEV_ID, strFSYS, strDSIZE, strFSPACE, strUSPACE
Dim strRAM, strVir, strPage, strOS, strSP, strProdID, strStatic
Dim strNIC, strIP, strMask, strGate, strMAC, strProc, strSpeed
set adsi = CreateObject("ADSystemInfo")
set wscr = CreateObject("WScript.Network")
Set WshShell = WScript.CreateObject("WScript.Shell")
strDomain = WshShell.ExpandEnvironmentStrings("%USERDOMAIN%")
outputFile = "C:\PC_Inv_NA.txt"
TITLE = WScript.ScriptName
Call KillFile()
set fso = CreateObject("Scripting.FileSystemObject")
' set fsox = CreateObject("Scripting.FileSystemObject")
' set fx = fsox.OpenTextFile(outputFile, ForWriting, True)
set fx = fso.OpenTextFile(outputFile, ForWriting, True)
computerIndex = 1
'******************
'**[ FUNCTIONS ]***************
Function Ask(strAction)
intButton = MsgBox(strAction, vbQuestion + vbYesNo, TITLE)
Ask = intButton = vbNo
End Function
'**[ MAIN SCRIPT ]*************
If Ask("Soll Inventur gestartet werden?") Then
Wscript.Quit
Else
strStart = "Programmstart: " & Date & " at " & time
End If
Call BuildXLS()
Call Connect()
Call Footer()
objXL.ActiveWorkbook.SaveAs "c:\sms.xls"
MsgBox "Programm beendet!", vbInformation + vbOKOnly, TITLE
'******************
Sub Connect()
set ObjDomain = GetObject("WinNT://" + strDomain)
ObjDomain.Filter = Array("Computer")
For each ObjComp in ObjDomain
strPC = ObjComp.name
Call Error()
On Error Resume Next
strCompName = UCase(strPC)
set BIOSSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select SerialNumber from Win32_BIOS")
for each BIOS in BIOSSet
strSN = BIOS.SerialNumber
Next
set MemorySet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select TotalPhysicalMemory, TotalVirtualMemory, TotalPageFileSpace from Win32_LogicalMemoryConfiguration")
for each Memory in MemorySet
strRAM = FormatNumber(Memory.TotalPhysicalMemory/1024,1) & " Mbytes"
strVir = FormatNumber(Memory.TotalVirtualMemory/1024,1) & " Mbytes"
strPage = FormatNumber(Memory.TotalPageFileSpace/1024,1) & " Mbytes"
Next
set OSSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select Caption, CSDVersion, SerialNumber from Win32_OperatingSystem")
for each OS in OSSet
strOS = OS.Caption
strSP = OS.CSDVersion
strProdID = OS.SerialNumber
Next
set IPConfigSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select ServiceName, IPAddress, IPSubnet, DefaultIPGateway, MACAddress from Win32_NetworkAdapterConfiguration where IPEnabled=TRUE")
Count = 0
for each IPConfig in IPConfigSet
Count = Count + 1
Next
ReDim sName(Count - 1)
ReDim sIP(Count - 1)
ReDim sMask(Count - 1)
ReDim sGate(Count - 1)
ReDim sMAC(Count - 1)
Count = 0
for each IPConfig in IPConfigSet
sName(Count) = IPConfig.ServiceName(0)
strNIC = sName(Count)
sIP(Count) = IPConfig.IPAddress(0)
strIP = sIP(Count)
sMask(Count) = IPConfig.IPSubnet(0)
strMask = sMask(Count)
sGate(Count) = IPConfig.DefaultIPGateway(0)
strGate = sGate(Count)
sMAC(Count) = IPConfig.MACAddress(0)
strMAC = sMAC(Count)
Count = Count + 1
Next
set ProSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select Name, MaxClockSpeed from Win32_Processor")
for each Pro in ProSet
strProc = Pro.Name
strSpeed = Pro.MaxClockSpeed
Next
Call Disk_C()
Call Disk_D()
Call Disk_E()
Next ' --- Computer Object
End Sub
Sub BuildXLS()
intRow = 1
Set objXL = Wscript.CreateObject("Excel.Application")
objXL.Visible = True
objXL.WorkBooks.Add
objXL.Rows(1).RowHeight = 40
objXL.Columns(1).ColumnWidth = 14
objXL.Columns(2).ColumnWidth = 15
objXL.Columns(3).ColumnWidth = 7
objXL.Columns(4).ColumnWidth = 7
objXL.Columns(5).ColumnWidth = 11
objXL.Columns(6).ColumnWidth = 11
objXL.Columns(7).ColumnWidth = 11
objXL.Columns(8).ColumnWidth = 12
objXL.Columns(9).ColumnWidth = 12
objXL.Columns(10).ColumnWidth = 12
objXL.Columns(11).ColumnWidth = 32
objXL.Columns(12).ColumnWidth = 13
objXL.Columns(13).ColumnWidth = 24
objXL.Columns(14).ColumnWidth = 10
objXL.Columns(15).ColumnWidth = 12
objXL.Columns(16).ColumnWidth = 12
objXL.Columns(17).ColumnWidth = 12
objXL.Columns(18).ColumnWidth = 17
objXL.Columns(19).ColumnWidth = 24
objXL.Columns(20).ColumnWidth = 7
'*** Set Cell Format for Column Titles ***
objXL.Range("A1:T1").Select
objXL.Selection.Font.Bold = True
objXL.Selection.Interior.ColorIndex = 9
objXL.Selection.Interior.Pattern = 1 'xlSolid
objXL.Selection.Font.ColorIndex = 2
objXL.Selection.WrapText = True
objXL.Columns("A:T").Select
objXL.Selection.HorizontalAlignment = 3 'xlCenter
Call AddLineToXLS("Computer Name","Serial Number","Device ID","File System","Disk Size","Free Space","Used Space","Physical Memory","Virtual Memory","Page File","Operating System","Service Pack","Product ID","Network Card","IP Address","Subnet Mask","Default Gateway","MAC Address","Processor","Speed")
End Sub
Sub AddLineToXLS(strCompName, strSN, strDEV_ID, strFSYS, strDSIZE, strFSPACE, strUSPACE, strRAM, strVir, strPage, strOS, strSP, strProdID, strNIC, strIP, strMask, strGate, strMAC, strProc, strSpeed)
objXL.Cells(intRow, 1).Value = strCompName
objXL.Cells(intRow, 2).Value = strSN
objXL.Cells(intRow, 3).Value = strDEV_ID
objXL.Cells(intRow, 4).Value = strFSYS
objXL.Cells(intRow, 5).Value = strDSIZE
objXL.Cells(intRow, 6).Value = strFSPACE
objXL.Cells(intRow, 7).Value = strUSPACE
objXL.Cells(intRow, 8).Value = strRAM
objXL.Cells(intRow, 9).Value = strVir
objXL.Cells(intRow, 10).Value = strPage
objXL.Cells(intRow, 11).Value = strOS
objXL.Cells(intRow, 12).Value = strSP
objXL.Cells(intRow, 13).Value = strProdID
objXL.Cells(intRow, 14).Value = strNIC
objXL.Cells(intRow, 15).Value = strIP
objXL.Cells(intRow, 16).Value = strMask
objXL.Cells(intRow, 17).Value = strGate
objXL.Cells(intRow, 18).Value = strMAC
objXL.Cells(intRow, 19).Value = strProc
objXL.Cells(intRow, 20).Value = strSpeed
intRow = intRow + 1
objXL.Cells(1, 1).Select
End Sub
Sub AddLineToDisk(strDEV_ID, strFSYS, strDSIZE, strFSPACE, strUSPACE)
objXL.Cells(intRow, 3).Value = strDEV_ID
objXL.Cells(intRow, 4).Value = strFSYS
objXL.Cells(intRow, 5).Value = strDSIZE
objXL.Cells(intRow, 6).Value = strFSPACE
objXL.Cells(intRow, 7).Value = strUSPACE
intRow = intRow + 1
objXL.Cells(1, 1).Select
End Sub
Sub Disk_C()
set DiskSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select DeviceID, FileSystem, Size, FreeSpace from Win32_LogicalDisk where DeviceID = 'C:' and DriveType = '3'")
ReDim strDisk(RowNum,4)
for each Disk in DiskSet
strDisk(RowNum,DEV_ID)= Disk.DeviceID
strDisk(RowNum,FSYS)= Disk.FileSystem
strDisk(RowNum,DSIZE)= FormatNumber(Disk.Size/2^30,1) & " Gbytes"
strDisk(RowNum,FSPACE)= FormatNumber(Disk.FreeSpace/2^30,1) & " Gbytes"
strDisk(RowNum,USPACE)= FormatNumber((Disk.Size-Disk.FreeSpace)/2^30,1) & " Gbytes"
Call AddLineToXLS(strCompName, strSN, strDisk(RowNum,DEV_ID), strDisk(RowNum,FSYS), strDisk(RowNum,DSIZE), strDisk(RowNum,FSPACE), strDisk(RowNum,USPACE), strRAM, strVir, strPage, strOS, strSP, strProdID, strNIC, strIP, strMask, strGate, strMAC, strProc, strSpeed)
Next
End Sub
Sub Disk_D()
set DiskSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select DeviceID, FileSystem, Size, FreeSpace from Win32_LogicalDisk where DeviceID = 'D:' and DriveType = '3'")
On Error Resume Next
ReDim strDisk(RowNum,4)
for each Disk in DiskSet
strDisk(RowNum,DEV_ID)= Disk.DeviceID
strDisk(RowNum,FSYS)= Disk.FileSystem
strDisk(RowNum,DSIZE)= FormatNumber(Disk.Size/2^30,1) & " Gbytes"
strDisk(RowNum,FSPACE)= FormatNumber(Disk.FreeSpace/2^30,1) & " Gbytes"
strDisk(RowNum,USPACE)= FormatNumber((Disk.Size-Disk.FreeSpace)/2^30,1) & " Gbytes"
If IsNull(strDisk(RowNum,FSYS)) Then
Exit Sub
End If
Call AddLineToDisk(strDisk(RowNum,DEV_ID), strDisk(RowNum,FSYS), strDisk(RowNum,DSIZE), strDisk(RowNum,FSPACE), strDisk(RowNum,USPACE))
Next
End Sub
Sub Disk_E()
set DiskSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select DeviceID, FileSystem, Size, FreeSpace from Win32_LogicalDisk where DeviceID = 'E:' and DriveType = '3'")
On Error Resume Next
ReDim strDisk(RowNum,4)
for each Disk in DiskSet
strDisk(RowNum,DEV_ID)= Disk.DeviceID
strDisk(RowNum,FSYS)= Disk.FileSystem
strDisk(RowNum,DSIZE)= FormatNumber(Disk.Size/2^30,1) & " Gbytes"
strDisk(RowNum,FSPACE)= FormatNumber(Disk.FreeSpace/2^30,1) & " Gbytes"
strDisk(RowNum,USPACE)= FormatNumber((Disk.Size-Disk.FreeSpace)/2^30,1) & " Gbytes"
If IsNull(strDisk(RowNum,FSYS)) Then
Exit Sub
End If
Call AddLineToDisk(strDisk(RowNum,DEV_ID), strDisk(RowNum,FSYS), strDisk(RowNum,DSIZE), strDisk(RowNum,FSPACE), strDisk(RowNum,USPACE))
Next
End Sub
Sub KillFile()
Set objKill = CreateObject("Scripting.FileSystemObject")
If (objKill.FileExists("c:\sms.xls")) Then
objKill.DeleteFile("c:\sms.xls")
End If
If (objKill.FileExists("c:\PC_Inv_NA.txt")) Then
objKill.DeleteFile("c:\PC_Inv_NA.txt")
End If
Set objKill = Nothing
End Sub
Sub Footer()
strFooter1 = "Janke, DTC"
strFooter2 = "Script für PC Hardware Inventory"
strComplete = "Progammende : " & Date & " um " & time
intRow = intRow + 5
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strFooter1
intRow = intRow + 1
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strFooter2
intRow = intRow + 1
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strStart
intRow = intRow + 1
'** Set Cell Format for Row
objXL.Cells(intRow, 1).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlLeft
objXL.Cells(intRow, 1).Value = strComplete
intRow = intRow + 1
End Sub
Sub Error()
On Error Resume Next
set CompSet = GetObject("winmgmts:{impersonationLevel=impersonate}!//" & strPC & "/root/cimv2").ExecQuery("select Name from Win32_ComputerSystem")
If Err Then
fx.WriteLine(strPC)
End If
computerIndex = computerIndex + 1
End Sub
#########################################################################
>>> hdd-test-kopieren.vbs <<<
'v4.9********************************************************
' File: hdd-test-kopieren.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zum Testen der Festplatte bzw. der Datenübertragung (auch
' im Netz) werden Daten aus einem Verzeichnis in ein anderes
' kopiert - die Lesegeschwindigkeit spielt also auch eine
' Rolle.
'************************************************************
' Option Explicit
Dim fso, WSHShell, ShellAppl, Daten, LaufWerk, i, FileOut, Text, TextX
Dim Menge, LwFrei, Nr, ZielVerz, ZielLw, Zeit, Zeit2, MaxTst
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Daten = "C:\copy-tst"
Daten = "C:\cc-tst"
Daten = "C:\temp"
Daten = "C:\DRVS"
Daten = "C:\DRVS"
Daten = "C:\tester"
Daten = "C:\daten.tst"
Daten = "D:\TOOLS"
ZielVerz = "c:\1-tst-"
ZielVerz = "d:\1-tst-"
ZielVerz = "c:\1-tst-"
ZielLw = ""
ZielLw = "V:" ' bei RAM-Disk = V:
ZielLw = ""
MaxTst = 999
LaufWerk = fso.GetDriveName( ZielVerz )
Text = " "
'Wenn ZielLaufWerk doch keine RAM-Disk ist:
' if not FSO.GetDrive(ZielLW).DriveType = 5 then ZielLw = ""
' ZielLw kann eine RAM-Disk sein
If fso.DriveExists(ZielLw) then
if not fso.FolderExists( Daten ) then
wshshell.Popup "Das Verzeichnis " & Daten & " mit den Daten, die kopiert werden sollen, existiert nicht!" , 10, WScript.ScriptName , 32+16
WScript.Quit
End If
' Wenn es das Daten-Verzeichnis gibt, soll es gelöscht werden
' If fso.FolderExists( Left(ZielLw, 2) & Mid(Daten, 3) ) then fso.DeleteFolder(Left(ZielLw, 2) & Mid(Daten, 3) ), true
' Das Daten-Verzeichnis bis zum Überquellen füllen, wenn es sich auf der RAM-Disk befindet
Text = ""
If not fso.FolderExists( Left(ZielLw, 2) & Mid(Daten, 3) ) then
Text = " "
ShellFolderCopy Daten, Left(ZielLw, 2) & Mid(Daten, 3)
If not Text = "" Then
MsgBox "Fehler beim Füllen des Daten-Verzeichnis!" & vbCRLF & vbCRLF & Text & vbCRLF & vbCRLF & ". . . das ist das Ende!", , WScript.ScriptName
WScript.Quit
End If
End If
Daten = Left(ZielLw, 2) & Mid(Daten, 3)
End If
ParamAbfrage ' Function Aufruf
If Len(Daten) < 4 then
wshshell.Popup "Als Quelle für die Daten, die kopiert werden sollen, muss ein Verzeichnis angegeben werden!" , 10, WScript.ScriptName , 32+16
WScript.Quit
End If
if not fso.FolderExists( Daten ) then
wshshell.Popup "Das Verzeichnis " & Daten & " mit den Daten, die kopiert werden sollen, existiert nicht!" , 10, WScript.ScriptName , 32+16
WScript.Quit
End If
Menge = CLng(FormatNumber(fso.GetFolder( Daten ).size/1024/1024, 1))
Text = "Die Dateien im Verzeichnis " & Daten & " (" & Menge & "MB) " & vbCRLF
Text = Text & "werden jetzt " & MaxTst & " mal nach " & ZielVerz & " kopiert " & vbCRLF
Text = Text & "oder bis dort nur noch " & Menge * 2 & " MB frei sind. "
If vbNo = wshshell.Popup (Text , 10, WScript.ScriptName, 32 + 4 ) then
wshshell.Popup " . . . denn eben nicht!" , 10, WScript.ScriptName , 64
WScript.Quit
End If
if not fso.FolderExists(ZielVerz) Then
fso.CreateFolder(ZielVerz)
End If
i=0
LogDatei vbCRLF & now()
LogDatei " " & CLng(FormatNumber(fso.GetFolder( Daten ).size /1024/1024, 0)) & "MB von " & Daten & " nach " & ZielVerz
Menge = CLng(FormatNumber(fso.GetFolder( Daten ).size /1024/1024, 0))
Zeit = now()
Do
LwFrei = CDbl(FormatNumber(fso.GetDrive ( fso.GetDriveName( ZielVerz ) ).FreeSpace/1024/1024, 1))
' genügend Speicher frei?
if LwFrei > (2.00 * Menge) then
if i > 998 then Exit Do
if i > MaxTst - 1 then Exit Do
i = i + 1
nr = i
if Len(CStr(nr)) = 1 then nr = "0" & nr
if Len(CStr(nr)) = 2 then nr = "0" & nr
' if Len(CStr(nr)) = 3 then nr = "0" & nr
Zeit = Zeit - now()
Text = "Durchlauf " & nr & " wird gestartet. - "
Text = Text & Menge & " MB werden nach " & ZielVerz & " kopiert." & vbCRLF & vbCRLF
' Text = Text & "Bisher wurden insgesamt " & CLng(FormatNumber(fso.GetFolder( ZielVerz ).size/1024/1024, 0)) & "MB kopiert."
Text = Text & "Z.Z. sind auf " & fso.GetDriveName( ZielVerz ) & " " & LwFrei & " MB frei. "
if vbcancel = wshshell.Popup (Text , 10, WScript.ScriptName & " - " & CDate(Zeit), 64 + 1 ) then
i = i - 1
Zeit = Zeit + now()
Exit Do
End If
Zeit = Zeit + now()
Kopieren ' Function Kopieren Aufruf
Else
wshshell.Popup i & " Durchläufe absolviert. (" & LwFrei & " MB frei)" , 10, WScript.ScriptName , 64
exit do
End If
Loop
Zeit = CDate( now() - Zeit )
If CDate(Zeit ) < CDate( "00:00:01") then
wshshell.Popup "kleiner als 00:00:01 ist " & CDate(Zeit) , 10, WScript.ScriptName , 64
Zeit = CDate("00:00:01")
End If
Zeit = Second(Zeit) + 60* Minute(Zeit) + 60*60* Hour(Zeit)
TextX = CLng( FormatNumber( fso.GetFolder( ZielVerz ).size/1024/1024, 3))
Zeit = "In " & Zeit & " Sekunden wurden " & TextX & "MB kopiert - das sind ca. " & FormatNumber(TextX / Zeit, 2) & "MB/s. Es ist jetzt " & now()
LogDatei Zeit
Text = i & " mal " & Menge & " MB nach " & ZielVerz & "\xxx kopiert. (" & LwFrei & " MB frei)" & vbCRLF & vbCRLF
Text = Text & "Soll das Testverzeichnis " & ZielVerz & " mit "
Text = Text & TextX & " MB gelöscht werden?" & vbCRLF & vbCRLF
Text = Text & Zeit
If vbNo = wshshell.Popup (Text , 10, WScript.ScriptName, 32 + 4 ) then WScript.Quit
fso.DeleteFolder ZielVerz, True
if fso.FolderExists(ZielVerz) Then wshshell.Popup ZielVerz & " konnte nicht richtig gelöscht werden!" , 60, WScript.ScriptName , 32+16
if not fso.FolderExists(ZielVerz) Then wshshell.Popup ZielVerz & " wurde gelöscht!", 3, WScript.ScriptName
WScript.Quit
'*********************************
Function Kopieren ' Aufruf
'*********************************
Zeit2 = now()
if not fso.FolderExists(ZielVerz & "\" & Nr) Then fso.CreateFolder(ZielVerz & "\" & Nr)
' Text = "%comspec% /c xcopy /S/E " & Daten & "\*.* " & ZielVerz & "\" & Nr & "\*.*"
' WSHShell.run Text, 4, True
' WSHShell.run Text, 0, True
'************************************************************
' fso.CopyFolder Daten, ZielVerz & "\" & Nr, True
' MsgBox Daten & " - " & ZielVerz & "\" & Nr
ShellFolderCopy Daten, ZielVerz & "\" & Nr
If not Text = "" Then
MsgBox "Fehler/Abbruch beim Kopieren nach " & ZielVerz & "\" & Nr & " !" & vbCRLF & vbCRLF & Text & vbCRLF & vbCRLF & ". . . das ist das Ende!", , WScript.ScriptName
WScript.Quit
End If
Zeit2 = now() - Zeit2
If CDate(Zeit2 ) < CDate( "00:00:01") then Zeit2 = CDate("00:00:01")
Zeit2 = Second(Zeit2) + 60* Minute(Zeit2) + 60*60* Hour(Zeit2)
Text = FormatNumber(fso.GetFolder( ZielVerz & "\" & Nr ).size/1024/1024, 3)
Zeit2 = " " & i & vbTab & Zeit2 & "s " & vbTab & Text & "MB " & vbTab & FormatNumber(Text / Zeit2, 2) & "MB/s " & vbTab & vbTab & now()
LogDatei Zeit2
End Function ' Kopieren
'*********************************
Function ParamAbfrage ' Aufruf
'*********************************
Text = ""
Text = Text & MaxTst & " mal " & vbCRLF
Text = Text & vbTab & "werden die Daten von " & vbCRLF & Daten & vbCRLF
Text = Text & vbTab & "nach " & vbCRLF & ZielVerz & vbCRLF
Text = Text & vbTab & "kopiert - ist das korrekt?"
Text = wshshell.Popup (Text , 20, WScript.ScriptName, 32 + 4 )
If not Text = vbNo Then Exit Function
if not fso.FolderExists( Daten ) then Daten = ""
Daten = InputBox ("Aus welchem Verzeichnis sollen die Daten zum Kopieren verwendet werden?", WScript.ScriptName, Daten )
ZielVerz = InputBox ("In welches Verzeichnis sollen die Daten aus " & Daten & " kopiert werden?", WScript.ScriptName, ZielVerz )
MaxTst = InputBox ("Wie oft (max 999) soll der Kopiervorgang der Daten von " & Daten & " nach " & ZielVerz & " wiederholt werden?", WScript.ScriptName, MaxTst)
ParamAbfrage ' Function Aufruf
End Function ' ParamAbfrage
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & "_" & Left(ZielVerz, 1) & "_ .log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
Set FileOut = Nothing
End Sub ' LogDatei
'*********************************
Sub ShellFolderCopy (Quelle, Ziel) ' Aufruf
'*********************************
' für eine Fortschritsanzeige bei Kopiervorgängen muss: shell32.dll version 4.71 or later
' http://msdn.microsoft.com/library/en-us/shellcc/platform/Shell/reference/objects/folder/copyhere.asp
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME )
Text = "\system32"
If not "Windows_NT" = WScript.CreateObject("WScript.Shell").Environment("Process")("OS") then Text = "\system"
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
Text = fso.GetFileVersion( text ) ' Versionsinfo (der Shell32.dll) holen
' wshshell.Popup "Die Shell32.dll hat die Version " & Text , 3, WScript.ScriptName
Text = Left ( CDbl ( text ), 3 ) ' Versionsinfo formatieren
If Text < 471 then
On Error Resume Next
fso.CopyFolder Quelle, Ziel, True
if not err.Number = 0 Then Text = err.Number & ": " & err.Description
On Error GoTo 0
Else
if not fso.FolderExists( Ziel ) then fso.CreateFolder( Ziel )
Set ShellApp = CreateObject("Shell.Application")
Set oZielOrdner = ShellApp.NameSpace( Ziel )
On Error Resume Next
Text = ""
oZielOrdner.CopyHere Quelle , 16 'vOptions
if not err.Number = 0 Then Text = err.Number & ": " & err.Description
On Error GoTo 0
Set oZielOrdner = nothing
Set ShellApp = nothing
End If
End Sub ' ShellFolderCopy
#########################################################################
>>> hdd0-test.vbs <<<
'v5.A*****************************************************
' File: hdd0-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Zeigt Infos zu Laufwerk C:.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Txt, Tst, i
Dim oExec
Const HDD = "DISK 0"
' Größe der HDD ermitteln
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set oExec = WSHShell.Exec( "diskpart.exe" )
Do While Not oExec.StdOut.AtEndOfStream
WScript.Sleep 15
Txt = oExec.StdOut.ReadLine
Tst = Tst & Txt & vbCRLF
' MsgBox Txt & vbCRLF & vbCRLF & Tst, , "0029 :: " ' zeigt in der ersten Zeile die letzte Ausgabe
If InStr( UCase( Txt ), "COMPUTER" ) > 0 Then oExec.StdIn.Write "list disk" & vbCRLF
If InStr( UCase( Txt ), "GB " ) > 0 Then oExec.StdIn.Write "exit" & vbCRLF : Exit Do
WScript.Sleep 15
Loop
oExec.Terminate
Set oExec = nothing
MsgBox Tst, , "0039 :: " ' Anwendung ist beendet
Tst = Split(Txt, " ", -1)
For i = LBound( Tst ) to UBound( Tst )
If InStr( Tst(i), "GB" ) Then Txt = Tst(i-1) ' Größe der HDD in GB
Next
Txt = "Laufwerk C: ist " & Txt & " GB groß."
WSHShell.Popup Txt ,30 , "0048 :: " & WScript.ScriptName, 4096 + 256
WScript.Quit
#########################################################################
>>> hintergrundbild.vbs <<<
'v6.2*****************************************************
' File: hintergrundbild.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'
' Ändert das Hintergrundbild des Desktops.
' (http://www.microsoft.com/communities/newsgroups/en-us/default.aspx?dg=microsoft.public.de.german.scripting.wsh&tid=1f4be8a0-4876-4d10-9a3f-6544d603888d&p=1)
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const sWallPaper = "C:\test.bmp"
' update in registry
WScript.CreateObject("WScript.Shell").RegWrite "HKCU\Control Panel\Desktop\Wallpaper", sWallPaper
' let the system know about the change
CreateObject("WScript.Shell").Run "%windir%\System32\RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", 1, True
#########################################################################
>>> historyfavoritesloeschen.vbs <<<
'v2.A*****************************************************
' File: HistoryFavoritesLoeschen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' History- & Favoriten-Verzeichnis loeschen: dazu müssen
' noch die entsprechenden fso.DeleteFolder - Zeilen frei
' gegeben werden
'*********************************************************
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Desktop = Left(WshShell.SpecialFolders("Desktop"), InStrRev(WshShell.SpecialFolders("Desktop"), "\") -1)
' ********** Cookies **********
' C:\WINNT\Profiles\xs30sey\Cookies
' das "Cookies" - Verzeichnis liegt im gleichen Verzeichnis wie andere
' WshSpecialFolders. Z.B. über das "Desktop"-Verzeichnis läßt sich der Pfad aufbauen:
VerzDel = Desktop & "\Cookies"
If fso.FolderExists(VerzDel) Then
Set VerzDel = fso.GetFolder(VerzDel))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """Cookies"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
' ********** Auslagerungsdatei **********
' Folgender Eintrag sorgt dafür, dass die Auslagerungsdatei beim Beenden gelöscht wird.
' So können später dort keine Daten ausgelesen werden.
' [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Memory Management]
' "ClearPageFileAtShutdown"=dword:00000001
' ********** Dokumente 1 **********
' Die Zeichenfolge NoRecentDocsHistory im Registry-Schlüssel
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' hindert Windows am weiteren Mitprotokollieren der zuletzt geöffneten Dokumente.
' Lässt eine bestehende Liste ebenso wie den Menüpunkt 'Dokumente' im Startmenü
' jedoch unberührt (siehe c't 6/02, S.258)
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' NoRecentDocsHistory
' ********** Dokumente 2 **********
' Die Zeichenfolge ClearRecentDocsOnExit im Registry-Schlüssel
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' veranlasst Windows, die Liste der zuletzt geöffneten Dokumente beim nächsten Herunterfahren
' zu löschen. Abmelden reicht nicht, auch der Befehl 'rundll32.exe user,exitwindows' lässt
' die Dokumenten-Liste intakt. Hindert Windows zudem nicht an der weiteren Protokollierung.
' Löscht außerdem die Listen der zuletzt eingegebenen URLs sowie der zuletzt unter AUSFÜHREN
' eingegebenen Befehle.
' HKEY_CURRENT_USER\Software\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
' ClearRecentDocsOnExit
' ********** Favoriten **********
' das "Favoriten" - Verzeichnis läßt sich leicht durch das
' WshSpecialFolders - Objekt ermitteln
If fso.FolderExists(WshShell.SpecialFolders("Favorites")) Then
Set VerzDel = fso.GetFolder(WshShell.SpecialFolders("Favorites"))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """Favoriten"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
' ********** Verlauf **********
' das "Verlauf" - Verzeichnis liegt im gleichen Verzeichnis wie andere
' WshSpecialFolders. Z.B. über das "Desktop"-Verzeichnis läßt sich der Pfad aufbauen:
VerzDel = Desktop & "\Verlauf"
If fso.FolderExists(VerzDel) Then
Set VerzDel = fso.GetFolder(VerzDel))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """Verlauf"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
' ********** His6 **********
' Der Verlauf des IE v5.0 liegt (neben Desktop) und heißt bei mir "His6".
' Ich bekommen unter NT4 beim Lösch-Versuch "Erlaubnis verweigert".
' Beim Aufruf über die "Autostart"-Gruppe geht's aber, wenn die MsgBox-
' Zeilen deaktiviert sind.
VerzDel = Desktop & "\His6"
If fso.FolderExists(VerzDel) Then
Set VerzDel = fso.GetFolder(VerzDel))
' *** folgende Zeile frei geben
' fso.DeleteFolder(VerzDel), True
' *** folgende Zeile NICHT frei geben
MsgBox """His6"" - Verzeichnis gelöscht", vbOKOnly, WScript.ScriptName
End If
#########################################################################
>>> html2txt.vbs <<<
'*** v8.2 *** www.dieseyer.de ****************************
'
' Datei: html2txt.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' http://www.source-center.de/forum/showthread.php?t=25764
'
' Speichert den Quelltext (ohne Bilder, ohne CSS) in einer
' Datei (die gestartet wird).
'
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WWWSite : WWWSite = "http://dieseyer.de/tip/all128/index.html"
Dim SpeichernIn : SpeichernIn = "C:\html2txt.htm"
SpeichernIn = "C:\html2txt.txt"
Call Html2Txt( WWWSite, SpeichernIn )
WScript.CreateObject ("WScript.Shell").Run SpeichernIn
WScript.Quit
'*** v8.2 *** www.dieseyer.de ****************************
Function Html2Txt( SiteHtml, ZielDatei )
'*********************************************************
' On Error Resume Next
Dim msieapp : Set msieapp = CreateObject("internetexplorer.application") 'InternetExplorer.Application erstellen
Dim Txt
Const READYSTATE_COMPLETE = 4
With msieapp
.Navigate (SiteHtml) 'Seite ansteurn
.Visible = False 'Nicht sichtbar machen
Do While .Busy
'warten bis der Ie geladen ist
WScript.Sleep 50
Loop
Do While .ReadyState <> READYSTATE_COMPLETE
'warten bis die site geladen ist
WScript.Sleep 50
Loop
Txt = .document.documentElement.outerHTML 'in die variable strHtml den Html src speichern
.Quit 'beenden
End With
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(ZielDatei, 2, True).write Txt
End Function ' Html2Txt( SiteHtml, ZielDatei )
#########################################################################
>>> htmldateispeichern.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: htmldateispeichern.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' getURL( url, un, pw )
' zieht den Quelltext einer (Html-) Internetseite.
'
' http://www.source-center.de/forum/showthread.php?t=41077
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim HtmlSeite, Txt
HtmlSeite = "http://www.source-center.de/forum/showthread.php?t=41077"
Txt = getURL( HtmlSeite, "", "" )
MsgBox Txt
HtmlSeite = "http://dieseyer.de/index.html"
Txt = getURL( HtmlSeite, "", "" )
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( WSCript.ScriptFullName & ".html", 2, true ).Write( Txt )
WScript.CreateObject("WScript.Shell").Run WScript.ScriptFullName & ".html"
WScript.Quit
'*** v8.4 *** www.dieseyer.de *******************************
Function getURL( url, un, pw )
'************************************************************
' http://www.source-center.de/forum/showthread.php?t=41077
' Parameter : URL, UserName, Password
getURL=""
Dim oHTTP : Set oHTTP = CreateObject("MSXML2.XMLHTTP")
Call oHTTP.Open( "GET", url, False, un, pw )
oHTTP.Send
getUrl=oHTTP.ResponseText
Set oHTTP = Nothing
End Function ' getURL( url, un, pw )
#########################################################################
>>> http-server-test.vbs <<<
'v5.A***************************************************
' File: http-server-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Testet ob eine (Fehler-) Seite NICHT geladen wird
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const Link = "http://dieseyer.de/dse-wsh-scr-.html"
Const SuchBegriff = "2005"
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim StartZeit : StartZeit = Now()
Dim i, Tst, Text
LogDatei ( vbCRLF & Now() & vbTab & " Start von " & WScript.ScriptFullName )
Do
Do
Tst = now()
' Jede volle Minute
If Second( Tst ) = 0 Then
Text = Text & vbCRLF & Now() & vbTab & Tst & vbTab & i & " " & "32 :: "
End If
' Jede volle 5 Minuten
If Mid( Minute( Tst ), 2 ) = "5" OR Minute( Tst ) = 5 Then
If Second( Tst ) < 2 Then Text = Text & vbCRLF & Now() & vbTab & Tst & vbTab & i & " " & "32 :: "
End If
' Jede volle 10 Minuten
If Mid( Minute( Tst ), 2 ) = "0" OR Minute( Tst ) = 0 Then
If Second( Tst ) = 0 Then Text = Text & vbCRLF & Now() & vbTab & Tst & vbTab & i & " " & "33 :: "
End If
if not fso.FileExists( WScript.ScriptFullName ) Then Exit Do
Exit Do
Loop
if not fso.FileExists( WScript.ScriptFullName ) Then Exit Do
If not Text = "" Then i = i + 1 : Tst = TestLink( Link, SuchBegriff ) : LogDatei ( Now() & vbTab & Tst )
WScript.Sleep 10 : If not Text = "" Then Text = "" : WScript.Sleep 1*1000
Loop
LogDatei ( vbCRLF & Now() & vbTab & " Ende von " & WScript.ScriptFullName )
MsgBox vbTab & "Seit " & StartZeit & " wurde " & vbCRLF & Link & vbCRLF & vbTab & i & " mal getestet . . . ", , WScript.ScriptName
' WScript.CreateObject( "WScript.Shell" ).Run "notepad " & WScript.ScriptFullName & ".log"
WScript.Quit
'************************************************************
Function TestLink( Link, Tst )
'************************************************************
Dim MeinIE, READYSTATE_COMPLETE
' Dim oDoc, oArea, oRng
Set MeinIE = CreateObject("InternetExplorer.Application")
Do While MeinIE.Busy
' Warten bis der IE komplett geladen ist
WScript.Sleeep 50
Loop
MeinIE.Visible = False ' True
MeinIE.Navigate Link
Do While MeinIE.ReadyState <> 4
' Warten bis der IE die Site komplett geladen hat
WScript.Sleep 50
Loop
TestLink = MeinIE.document.body.innerText
If InStr( UCase( TestLink ), UCase( Tst ) ) > 0 Then
TestLink = "Seite ist aufrufbar."
Else
TestLink = "=> Seite ist nicht verfügbar."
End If
WScript.Sleep 500
MeinIE.Quit
End Function ' TestLink( Link )
' **************************************************************
Sub LogDatei (LogTxt) ' v3.9 - http://dieseyer.de
' **************************************************************
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(WScript.ScriptName & ".log", 8, true).WriteLine (LogTxt)
End Sub ' LogDatei (LogTxt) ' v3.9 - http://dieseyer.de
#########################################################################
>>> httpget.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
'
' Datei: httpget.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Skript wird als Beispiel das aktuelle Wetter (und weitere
' Daten) von 'http://www.webservicex.net/globalweather.asmx'
' für Berlin abgefragt, in einer XML-Datei gespeichert und
' angezeigt. Welche Abfragen vom Webservice angenommen werden
' erfährt man, wenn man dies WWW-Adr. im Browser eingibt.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim XMLDatei, Txt, Tst
Txt = "http://www.webservicex.net/globalweather.asmx/GetWeather?CityName=Stuttgart&CountryName=Germany"
Tst = HttpGet( Txt )
MsgBox Txt & vbCRLF & vbCRLF & vbTab & "ergab:" & vbCRLF & vbCRLF & Tst, , "21 :: " & WScript.ScriptName
XMLDatei = WScript.ScriptFullName & ".xml"
CreateObject("Scripting.FileSystemObject").OpenTextFile( XMLDatei , 2, True).Write Tst
WScript.Sleep 33
CreateObject("WScript.Shell").Run """" & XMLDatei & """", , False
WScript.Quit
'*** v9.A *** www.dieseyer.de ******************************
Function HttpGet( url )
'***********************************************************
' MsgBox url, , "34 :: "
Dim Tst, i
Dim httpRequest : Set httpRequest = CreateObject("Microsoft.XMLHTTP")
' httpRequest.setRequestHeader "Accept", "*/*"
' httpRequest.setRequestHeader "UserAgent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50215)"
' httpRequest.setRequestHeader "Timeout", 1000*60
' httpRequest.setRequestHeader "CWA-Ticket", 1 'this.authTicket
httpRequest.Open "GET", url, True
httpRequest.Send()
Tst = "" : i = 0
Do
Tst = Tst & i & ": " & vbTab & httpRequest.readyState & vbCRLF
If httpRequest.readyState = 4 Then Exit Do
i = i + 1 : If i > 300 Then Exit Do
WScript.Sleep 33
Loop
' MsgBox Tst , , "52 :: " & i
' MsgBox "httpRequest.Status: '" & httpRequest.Status & "'"
If httpRequest.Status = 200 Then
HttpGet = httpRequest.ResponseText
Else
HttpGet = "58 :: FEHLER - ENDE"
End If
Set httpRequest = nothing
End Function ' HttpGet( url )
#########################################################################
>>> icon.vbs <<<
'*** v9.4 *** www.dieseyer.de ******************************
'
' Datei: icon.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' In Hta kann ein Symbol (Icon) für das Hta definiert werden:
' ICON="dieseyer.ico"
' The ICON attribute in Hta can be set with
' ICON="dieseyer.ico"
' Die Prozedur IcoAusHexDaten() erstellt aus den im Hta
' hinterlegten Binärdaten eine Icon-Datei.
' Einfügen der Binärdaten eines Icons: Öffnen der Ico-Datei
' mit PSPad; die Anzeige erfolgt im HEX-Format. Mit
' [Strg-a][Strg-c] befindet sich die gesamte Datei im HEX-
' Format in der Zwischenablage. Diese Zeichenkette wird hier
' im Beispiel der Variable Tst zugewiesen. Beim Aufruf von
' IcoAusHexDaten( ZielDatei, Txt )
' werden die Zeichen in die Icon-Datei geschrieben.
'
' Aus einer 4KByte Ico-Datei wird eine 8KByte Zeichenkette!
'
' The procedure IcoAusHexDaten() create icon from data
' that was set in hta.
' Input data in hta: Open ico-file with pspad-editor in
' hex-view, press [ctrl-a], [ctrl-c] and paste the clipboard-
' string to variable 'Tst' in Hta-code.
'
' Vergl.
' http://dieseyer.de/scr/WIM-BuR.hta
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst
Tst = "0000010001002020000001001800A80C00001600000028000000200000004000000001001800000000000000000048000000480000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFBFBFBFDFDFDF2F2F2F5F5F5F0F0F0FFFFFFFFFFFFFAFAFAE1E1E1E6E6E6E6E6E6ECECECF4F4F4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFCE9E9E9ECECECF6F6F6FFFFFFF1F1F1E0E0E0F0F0F0FEFEFEFFFFFFFAFAFAEDEDEDF6F6F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFDFDFDFDFDFDEDEDEDE7E7E7FBFBFBF8F8F8DEDEDEE5E5E5FDFDFDFFFFFFFFFFFFFDFDFDFFFFFFFFFFFFF3F3F3F2F2F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8F6F6F6F2F2F2FBFBFBEEEEEED3D3D3ECECECFFFFFFFFFFFFFFFFFFF8F8F8E5E5E5FBFBFBFFFFFFFFFFFFF5F5F5FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF2F2F2F2F2F2FBFBFBE8E8E8D9D9D9F0F0F0FFFFFFFFFFFFFFFFFFFCFCFCAFAFAF9B9B9BE0E0E0FDFDFDFFFFFFFFFFFFFCFCFCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFEDEDEDE7E7E7DFDFDFF5F5F5FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFECECECF2F2F2F2F2F2FDFDFDFFFFFFF6F6F6FDFDFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE9E9E9DFDFDFD6D6D6F8F8F8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE0E0E0BDBDBDF0F0F0FFFFFFFAFAFAE4E4E4FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE9E9E9C5C5C5EAEAEAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFEFEFEFFFFFFD5D5D5F9F9F9FFFFFFFCFCFCBBBBBBF8F8F8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE2E2E2BEBEBEFAFAFAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEE5E5E5E4E4E4FBFBFBD7D7D7E0E0E0D7D7D7D5D5D5B4B4B4DCDCDCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF5F5F5CCCCCCC3C3C3EFEFEFFFFFFFE1E1E1DFDFDFF7F7F7DBDBDBD3D3D3ECECECB8B8B8DFDFDFDDDDDDD9D9D9AEAEAECFCFCFE7E7E7DCDCDCD9D9D9FDFDFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFCD9D9D9BBBBBBDEDEDEE7E7E7F7F7F7E4E4E4C5C5C5D8D8D8C1C1C1A1A1A1C2C2C2B6B6B6BBBBBBDFDFDFC9C9C9B5B5B5D7D7D7E5E5E5D0D0D0C6C6C6E6E6E6F9F9F9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8EEEEEEBCBCBCDFDFDFC2C2C2E5E5E5FCFCFCFFFFFFCDCDCDDEDEDEE8E8E8BABABAE9E9E9ACACAC5F5F5FA3A3A3AEAEAE7272728C8C8C646464A3A3A3B1B1B1C2C2C2E6E6E6F8F8F8F3F3F3FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8BFBFBFBCBCBCE3E3E3DADADAEEEEEEFFFFFFFFFFFFFEFEFEA3A3A3FDFDFDB6B6B63737379898987B7B7B5B5B5BACACACDBDBDBAAAAAAC6C6C67E7E7E6F6F6FADADADB3B3B3AEAEAEDFDFDFD3D3D3F3F3F3FFFFFFFFFFFFFFFFFFFFFFFFCDCDCD6A6A6AADADADE7E7E7DCDCDCE9E9E9FBFBFBFFFFFFFCFCFCBBBBBBDFDFDFA4A4A4ABABABC0C0C0575757A4A4A4FBFBFBF6F6F6F7F7F7FBFBFBDBDBDB8888889F9F9FA1A1A1808080B3B3B3B0B0B0D3D3D3FDFDFDFFFFFFFFFFFFFFFFFF717171555555999999DDDDDDB5B5B5CECECEF7F7F7DDDDDDBEBEBEB8B8B8D6D6D6B0B0B05757576C6C6CB0B0B0E8E8E8FFFFFFFFFFFFFFFFFFFFFFFFFEFEFEA4A4A4F9F9F9E9E9E98888888C8C8C8F8F8FBDBDBDE6E6E6FFFFFFFFFFFFFFFFFF4747474A4A4A707070A3A3A3B4B4B4B2B2B2D0D0D0AAAAAA979797969696A3A3A3717171535353CECECEE0E0E0DBDBDBFFFFFFFFFFFFFFFFFFFFFFFFF6F6F6A8A8A8FEFEFEE5E5E59696967979796F6F6F9D9D9DC6C6C6FDFDFDFFFFFFFFFFFF4A4A4A3B3B3B6464647C7C7C9595957C7C7C9595958484846A6A6A4D4D4D5C5C5C747474A3A3A3B9B9B9EEEEEEC6C6C6FEFEFEFFFFFFFFFFFFFFFFFFE1E1E1ABABABFEFEFEBBBBBBA7A7A78787875151518C8C8CB4B4B4FBFBFBFFFFFFFFFFFF4848483E3E3E7474748A8A8A7A7A7A6060608383838585858A8A8A6C6C6C747474959595949494929292FBFBFBB4B4B4F7F7F7FFFFFFFFFFFFFFFFFFBFBFBFB7B7B7F4F4F4858585AFAFAF7A7A7A4141417D7D7DA1A1A1F7F7F7FFFFFFFFFFFF5252525151512525257B7B7B6D6D6D515151787878787878A6A6A68F8F8F333333717171A6A6A6939393D1D1D1C4C4C4EBEBEBFFFFFFFFFFFFFEFEFE9F9F9FDCDCDCCDCDCD747474A8A8A86C6C6C6E6E6E656565777777EDEDEDFFFFFFFFFFFF5757576060605D5D5D8D8D8D6E6E6E6868687171716F6F6F8484848F8F8F6E6E6E515151979797BBBBBB828282E2E2E2DADADAFDFDFDFFFFFFFDFDFDBCBCBCF5F5F58D8D8D6666669A9A9A8383835F5F5F6C6C6C787878E9E9E9FFFFFFFFFFFF3D3D3D6E6E6E7A7A7A6969697878786E6E6E6A6A6A6262627C7C7C9898986E6E6E909090838383AEAEAE9D9D9D909090C3C3C3848484AAAAAAD4D4D4BDBDBDDCDCDC7D7D7D9494949999999898986767678E8E8E808080E9E9E9FFFFFFFFFFFF5959595252527E7E7E7575758B8B8B8A8A8A7E7E7E9696968686867A7A7A949494959595C9C9C9C7C7C7CECECEC2C2C2C4C4C4A8A8A8C1C1C1C8C8C8D6D6D6CBCBCBB5B5B5BFBFBFC2C2C2BEBEBE8A8A8A9393937A7A7AE7E7E7FFFFFFFFFFFF686868666666797979909090939393ABABAB888888999999B1B1B17D7D7DB9B9B9A7A7A7E4E4E4E8E8E8E7E7E7EEEEEEDADADADEDEDEE3E3E3FDFDFDF3F3F3EDEDEDF6F6F6F5F5F5DBDBDBE3E3E3D0D0D08B8B8B888888F9F9F9FFFFFFFFFFFF676767B0B0B0888888AAAAAAAFAFAFC8C8C89696969F9F9FBABABACDCDCDC6C6C6F0F0F0CECECEE1E1E1E1E1E1EDEDEDF8F8F8CFCFCFEBEBEBF5F5F5F5F5F5F8F8F8FDFDFDE3E3E3DDDDDDEFEFEFECECEC808080D5D5D5FFFFFFFFFFFFFFFFFF7A7A7A787878AFAFAFD6D6D6E0E0E0DFDFDFE5E5E5D1D1D1CCCCCCD9D9D9C3C3C3D5D5D5FDFDFDF8F8F8D4D4D4F0F0F0EAEAEAE8E8E8FDFDFDF2F2F2E5E5E5F7F7F7BDBDBDE0E0E0F4F4F4F8F8F8BFBFBFD3D3D3FEFEFEFFFFFFFFFFFFFFFFFF8B8B8B929292AFAFAFCACACAFCFCFCFDFDFDBEBEBEF4F4F4DBDBDBB5B5B5F4F4F4D3D3D3D0D0D0FEFEFEFFFFFFDDDDDDB6B6B6E5E5E5FFFFFFE9E9E9CFCFCFF9F9F9FFFFFFF4F4F4F0F0F0D8D8D8D1D1D1F9F9F9FFFFFFFFFFFFFFFFFFFFFFFFB7B7B79D9D9D676767E4E4E4E5E5E5DFDFDFEFEFEFCCCCCCF3F3F3F1F1F1DBDBDBFAFAFAEAEAEAD8D8D8F5F5F5CCCCCCCFCFCFE1E1E1F6F6F6F4F4F4F9F9F9E4E4E4D8D8D8F1F1F1E6E6E6C7C7C7EBEBEBFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F8F8B0B0B0747474999999CFCFCFD3D3D3D7D7D7F1F1F1DCDCDCF0F0F0E7E7E7DEDEDEEDEDEDF6F6F6C9C9C9B8B8B8E1E1E1EDEDEDDADADAC3C3C3E4E4E4F3F3F3F2F2F2E2E2E2D4D4D4DADADAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1F1F1AFAFAF8A8A8AC5C5C5DADADACFCFCFD5D5D5F7F7F7EFEFEFE3E3E3E0E0E0D9D9D9D5D5D5BFBFBFC6C6C6E7E7E7FCFCFCF8F8F8E7E7E7F8F8F8F8F8F8F1F1F1CACACAD8D8D8F2F2F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1F1F1CACACAA4A4A4B1B1B1E1E1E1DEDEDEB9B9B9E7E7E7F6F6F6F2F2F2EBEBEBD3D3D3E1E1E1EBEBEBEFEFEFDDDDDDE0E0E0F2F2F2DBDBDBDCDCDCD9D9D9DCDCDCDFDFDFFDFDFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFDFDFDE5E5E5E0E0E0A9A9A9D2D2D2DDDDDDE5E5E5DFDFDFFAFAFAFAFAFAEDEDEDE5E5E5F8F8F8F0F0F0E7E7E7E8E8E8E1E1E1C5C5C5BEBEBEE9E9E9E9E9E9FEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0F0F0DFDFDFECECECF2F2F2C5C5C5C0C0C0EFEFEFF7F7F7C4C4C4D5D5D5D5D5D5F6F6F6FEFEFEF4F4F4EEEEEEECECECDEDEDEE2E2E2FBFBFBFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
IcoAusHexDaten WScript.ScriptFullName & ".ico", Tst
MsgBox "Erledigt: " & WScript.ScriptFullName & ".ico", , WScript.ScriptName
WScript.Quit
'*** v9.4 *** www.dieseyer.de ******************************
Sub IcoAusHexDaten( ZielDatei, HexDaten )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileOut, Tst, i
' Läßt sich die ZielDatei anlegen?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
Set FileOut = fso.OpenTextFile( ZielDatei, 2, True )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then Exit Sub
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 1
Do
FileOut.Write Chr( CInt( "&H" & Mid( HexDaten, i, 2 ) ) )
i = i + 2 : If i > Len( HexDaten ) Then Exit Do
Loop
FileOut.Close
Set FileOut = nothing
' CreateObject("WScript.Shell").SendKeys "{F5}"
End Sub ' IcoAusHexDaten( ZielDatei, HexDaten )
#########################################################################
>>> icq5-verlauflesen.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: icq5-verlauflesen.vbs
' Autor: mike-winxp@gmx.de
' Auf: www.dieseyer.de
'
' Skript zum Lesen einer Verlaufsdatei (von icq5; ICQ v5.x).
' Die xml-Datei auf das Script ziehen und fallen lassen.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim epochdatum, shell, fso, I, a, pfad1, pfad, ergebnis, read, zeile, Farbe, messenge, objArgs
Set objArgs = WScript.Arguments
Set shell = Wscript.CreateObject("Wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Const tempdatei = "IcqNachrichten.hta"
' 1. Argumente aufnehmen
For I = 0 to objArgs.Count - 1
pfad = objArgs(I)
Next
' 2. Kontrolle (handelt es sich überhaupt um eine xml-Datiei?)
If instrRev(Right(pfad,3),"xml",-1,1) <> 1 Then
a = Msgbox ("Dieses Script funktioniert nur für xml-dateien von Icq",64,"Geht net")
Wscript.Quit
End If
' 3.Erstelle Dokument
Set ergebnis = fso.OpenTextFile(tempdatei,2,True)
ergebnis.WriteLine "<head>"
ergebnis.WriteLine "<title>Icq Nachrichten lesen</title>"
ergebnis.WriteLine "<" & "HTA:APPLICATION ID=""oHTA"""
ergebnis.WriteLine "Windowstate=""maximize"">"
ergebnis.WriteLine "<style type='text/css'>"
ergebnis.WriteLine "body,td,th {color: #CCCCCC;font-family: Arial, Helvetica, sans-serif;font-size: 10px;}body {background-color: #4a4a4a;}a {font-size: 10px;color: #CCCCCC;}a:link {text-decoration: none;}"
ergebnis.WriteLine "a:visited {text-decoration: none;color: #CCCCCC;}a:hover {text-decoration: underline;}a:active {text-decoration: none;}.Stil1 {font-size: 14px}.Stil2 {font-size: 10px; }"
ergebnis.WriteLine "</style></head><body>"
ergebnis.WriteLine "<table width='1148' border='0' align='center' bgcolor='3a3a3a' style='border: 1px outset #CCCCCC' height='146' > "
ergebnis.WriteLine "<tr><td height='142' width='1138'><div align='center'><table width='85%' border='0' align='center' bgcolor='#3a3a3a' ><div align='center' style='width: 888; height: 27'>"
ergebnis.WriteLine "<p class='Stil1'><font size='5'>Nachrichten an Icq Nummer: " & Left(Right(pfad,18),9) & "</font></p></div></table><p> </p>"
ergebnis.WriteLine " "
' 4.Liest die Datei aus
Set read = fso.OpenTextFile(pfad,1,True)
Do While read.AtEndOfStream <> True
zeile = read.ReadLine()
' von wem stammte die Nachricht?
If Instr(1,zeile, "<incoming>" ,1) >= 1 Then
ergebnis.WriteLine "<table width='1075' border='1' align='center' bgcolor='#3a3a3a' height='25' bordercolorlight='#C0C0C0' >"
If Instr(1,zeile, "<incoming>No</incoming>" ,1) >= 1 Then
Farbe = "#FF0000"
Else
Farbe = "#00FF00"
End If
End If
' Wann wurde die Nachricht verfasst?
If Instr(1,zeile, "<time>" ,1) >= 1 Then
Call epoch(Mid(zeile,8,10)) ' epochdatum
ergebnis.WriteLine "<td height='21' width='125'><font size='2'>" & epochdatum & "</font>"
End If
' Was wurde geschrieben?
If Instr(1,zeile, "<text>" ,1) >= 1 Then
messenge = right(zeile,Len(zeile)-7)
If Instr(1,messenge, chr(195),1) >= 1 Then
messenge = Replace(messenge, chr(195) & chr(188), "ü")
messenge = Replace(messenge, chr(195) & chr(182), "ö")
messenge = Replace(messenge, chr(195) & chr(159), "ß")
messenge = Replace(messenge, chr(195) & chr(164), "ä")
messenge = Replace(messenge, chr(195) & chr(150), "Ö")
messenge = Replace(messenge, chr(195) & chr(132), "Ä")
messenge = Replace(messenge, chr(195) & chr(156), "Ü")
End If ' messenge
ergebnis.WriteLine "<td height='21' width='925'><font size='3' color='" & Farbe & "'>" & messenge & "</font></table>"
End If
Loop
read.Close
ergebnis.WriteLine "<p><font size='3' color='#FF0000'>ausgehende Nachricht "
ergebnis.WriteLine "</font><font size='3' color='#00FF00'>ankommende Nachricht</font></p>"
ergebnis.WriteLine "<p> </p></div></td></tr></table></body>"
ergebnis.close
shell.Run tempdatei,1, True
fso.DeleteFile(tempdatei)
Wscript.Quit
'**************************************************************
Function epoch(epochtime)
epochdatum = DateAdd("s", epochtime, "01/01/1970 01:00:00")
End Function
#########################################################################
>>> icq6-verlauflesen.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: icq6-verlauflesen.vbs
' Autor: mike-winxp@gmx.de
' Auf: www.dieseyer.de
'
' Skript zum Lesen einer Verlaufsdatei (von icq6; ICQ v6.x).
' Dazu einfach die "Messages.mdb"-Datei auf das Script ziehen
' und fallen lassen. Die Datei befindet sich (unter WinXP):
' C:\Dokumente und Einstellungen\[UserName]\Anwendungsdaten\ICQ\[ICQ Nummer]\Messages.mdb
' %APPDATA%\ICQ\[Ihre ICQ Nummer]\Messages.mdb
'
'************************************************************
Option Explicit
Dim shell, db, ie, objArgs, x, pfad, dok, i, antwort, userid, history, messenge, Title, Nummer, Farbe, zahl, Icq_killen ,prozess
Set shell = CreateObject("WScript.Shell")
Set db = CreateObject("ADODB.Connection")
Set ie = CreateObject("InternetExplorer.Application")
Set objArgs = WScript.Arguments
For x = 0 To objArgs.Count - 1
pfad = objArgs(I)
Next
If pfad = "" Then
pfad = shell.SpecialFolders("AppData") & "\ICQ\[Ihre ICQ Nummer]\Messages.mdb" ' Bitte tragen sie ihre ICQ-Nummer ein
If instr(1, pfad, "[Ihre ICQ Nummer]", 1) > 1 Then Msgbox "Bitte passen Sie den Pfad an",16,"Error" : Wscript.Quit
End If
For Each prozess In GetObject("winmgmts:{impersonationLevel=impersonate,(Debug)}").ExecQuery ("SELECT * FROM Win32_Process")
If Instr("ICQ.exe",prozess.Name) > 0 Then
Icq_killen = Msgbox ("Anscheinend läuft ICQ noch. Um auf die Datenbank zugreifen zu können muss ICQ beendet werden" &_
vbCr & vbCr & "Wollen sie Icq jetzt beenden?" & vbCr &_
"Wählen Sie 'Ja' um ICQ jetzt zu beenden (ACHTUNG: Dadurch wird der Task ICQ.exe ""gekillt"")" & vbCr &_
"Wählen Sie 'Nein' um mit dem Script fortzufahren (Beenden Sie vorher ICQ manuell)" & vbCr &_
"Wählen Sie 'Abbrechen' um das Script abzubrechen" , 563 ,"ICQ läuft noch. Wie möchten sie fortfahren?")
If Icq_killen = 7 Then Msgbox "Bitte beenden Sie ICQ jetzt!",64, "ICQ jetzt beenden"
If Icq_killen = 2 Then wscript.Quit
If Icq_killen = 6 Then prozess.Terminate(0)
End If
Next
zahl = InputBox("Bitte geben Sie an, wieviele Nachrichten angezeigt werden sollen.", "Icq6 Verlauf", "500")
If zahl = 0 Then Wscript.Quit
ie.Navigate "about:blank"
While ie.Busy
Wend
Set dok = ie.Document
dok.Open
dok.Writeln "<Title>Verlauf Icq6</Title><B>Datenbank wird gelesen. Bitte warten . . . </b>"
dok.Close
ie.Visible = True
wscript.sleep 100
shell.AppActivate("Verlauf Icq6")
shell.SendKeys "% x"
db.Open("DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & pfad)
Set antwort = db.Execute("SELECT * FROM Messages" & " ORDER BY date DESC")
Set userid = db.Execute("SELECT * FROM Users")
Set history = db.Execute("SELECT * FROM ChatHistory")
For i = 0 To zahl
If antwort.EOF = True Then Exit For
x = x + 1 : If x = 10 Then Wscript.Sleep 3 : x = 0 ' Soll für geringere Prozessorauslastung sorgen
If "" & antwort(1) = "" Then
Farbe = "red"
Else ' black; maroon; green; olive; navy; purple; teal; gray; silver; red; lime; yellow; blue; fuchsia; aqua
Farbe = "blue"
End If
messenge = "<tr><td>" & Left(antwort(6),6) & Mid(antwort(6),9,8) & "</td><td> " &_
antwort(2) & "</td><td> " & antwort(1) & " </td><td><font color='" & Farbe & "'> " &_
antwort(8) & "</font></td></tr>" & messenge ' Damit die neueste Nachricht ganz oben steht muss es 'messenge = messenge & "....'
antwort.MoveNext
Next
Title = "<Title>Verlauf Icq6</Title><u><B>Gespräch mit:</b></u><BR>"
Nummer = "<u><B>User haben folgende Nummern:</b></u><BR>"
x = 0
Do Until userid.EOF
x = x + 1
messenge = Replace(messenge,userid(0),userid(1))
messenge = Replace(messenge, history(0), x)
Title = Title & userid(1) & " = " & x & "; "
Nummer = Nummer & userid(1) & " = " & userid(0) & "; "
userid.MoveNext
history.MoveNext
Loop
Title = Title & "<BR><BR><u><B>Verlauf:</b></u><BR>Die letzten " & zahl & " Nachrichten werden angezeitg<BR><table border='1' cellpadding='0' cellspacing='0' width='99%'>" &_
"<tr><td><B><center>Datum/Uhrzeit</center></td><td><B><center>ID</center></td><td><B><center>Name</center></td><td><B><center>Nachricht</center></td>"
dok.Open
dok.Write(Nummer & "<BR><BR>" & Title & "<BR><center><font color='blue'>eingehende Nachrichten</font> " &_
"<font color='red'>ausgehende Nachrichten</font></center><BR> " & messenge)
dok.Close
#########################################################################
>>> ie-start.vbs <<<
'v4.3*****************************************************
' File: ie-start.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Testet ob der Router bereit antwortet - wenn ja, testet
' das Skript, ob ein DNS erreichbar ist - wenn ja, wird
' der InternetExplorer gestartet.
'
' Sinnvoll im HeimNetzwerk, wenn der Router z.B. ein
' #fil14-Disketten-Router mit analogem Modem ist.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
DIM DefaultGW, Ziel, Text, TextX, Text1, Text2, Button, FileIn, i, x, y, z, MsgTxt, IPtst
DIM WSHShell, FSO, WSHNet, Env
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Set Env = WSHShell.Environment("PROCESS")
Ziel = "~T~m~p~.tmp"
Ziel = "winipcfg.out"
Const RouterIP = "192.168.150.249"
' Const RouterIP = "192.168.150.126"
' Const RouterIP = "192.168.150.127"
Const DNS1 = "192.76.144.66" ' MSN vom 10.02.2004
Const DNS2 = "145.253.2.75" ' Arcor vom 10.02.2004
Const DNS3 = "62.104.191.241" ' FreeNet.de vom 10.02.2004
DefaultGW = ""
GateWayNT
If DefaultGW = "" then MsgBox "Das Netzwerk ist nicht bereit bzw. " & vbCRLF & "es ist kein DefaultGateway eingetragen.", , WScript.ScriptName
If DefaultGW = "" then WScript.Quit
' Test ob Router bereit ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
z = 0
Do
Z = z + 1
' IPtst = RouterIP
IPtst = DefaultGW
MsgTxt = " " & IPtst & " Test " & z & " erfolglos"
IPTest
if Text1 = "True" then Exit Do
if z < 6 then wshshell.Popup "DefaultGateWay / Router ist nicht bereit!" , 2, MsgTxt, 48
if z > 5 then
Button = wshshell.Popup("DefaultGateWay / Router ist nicht bereit!" , 5, MsgTxt, 37)
if Button = 2 then
wshshell.Popup "Router Test erfolglos und erledigt - das ist das ENDE!" , 2, WScript.ScriptName, vbExclamation
WScript.Quit
End If
End If
Loop
' Test ob DNS? erreichbar bereit ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
z = 2
Do
z = z + 1
x = 1 + z - Int(z / 3) * 3
if x = 1 then IPtst = DNS1
if x = 2 then IPtst = DNS2
if x = 3 then IPtst = DNS3
if x = 1 then MsgTxt = " " & IPtst & "-DNS1 - Test " & z-2 & " erfolglos!"
if x = 2 then MsgTxt = " " & IPtst & "-DNS2 - Test " & z-2 & " erfolglos!"
if x = 3 then MsgTxt = " " & IPtst & "-DNS3 - Test " & z-2 & " erfolglos!"
IPTest
if Text1 = "True" then Exit Do
Button = wshshell.Popup("Internet-Verbindung ist noch nicht bereit!" , 4, MsgTxt, 37)
if Button = 2 then
wshshell.Popup "Internet-Verbindung ist nicht bereit - Test beendet." , 5, WScript.ScriptName, vbExclamation
WScript.Quit
End If
Loop
wshshell.Run "IEXPLORE.EXE"
WScript.Quit
' Test ob IP-Adr. erreichbar bereit ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub IPTest
WshShell.run ("%comspec% /c Ping " & IPtst & " -n 1 -w 500 > " & Ziel),0,true
' PING nur einmal ausführen => nur eine Zeile mit TTL=
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCrLf ,1) ' alles gelesene in Zeilen aufteilen
Text1 = "False"
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(TextX(i), "TTL=") > 1 then Text1 = "True"
next
End Sub
Sub GateWayNT
if Env("OS") = "Windows_NT" then
WSHShell.run "%comspec% /c ipconfig > " & Ziel, 0, True ' ipconfig nach Ziel umleiten
else
WSHShell.run "winipcfg /batch" ,0 ,True ' winipcfg /batch legt autom. "winipcfg.out" an
end if
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
' folgende Zeile freigeben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(UCase(TextX(i)), "GATEWAY") then
DefaultGW = Mid(TextX(i), InStr(UCase(TextX(i)), ": ") + 1)
DefaultGW = trim(DefaultGW)
End If
next
End Sub
#########################################################################
>>> immerwieder.vbs <<<
'v5.B*****************************************************
' File: immerwieder.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Startet regelmäßig verschiedene Skripte.
'
'*********************************************************
' Das Skript beendet sich, wenn es gelöscht wird.
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim n
Dim nach : nach = Array( 10, 20, 30, 50, 59 ) ' gestartet werden "10.vbs" "20.vbs" .. "59.vbs"
MsgBox "Es geht los!", , "0020 :: " & WScript.ScriptName
' MsgBox UBound( nach ), , "0022 :: " & WScript.ScriptName
Do
For n = LBound( nach ) To UBound( nach )
If Second(now) = nach( n ) Then
' If Minute(now) = nach( n ) Then
' WSHShell.Run( nach( n ) & ".vbs" )
MsgBox nach( n ) & ".vbs", , "0029 :: " & WScript.ScriptName
End If
Next
WScript.Sleep 250 ' alle 1/4 Sekunde bei ==>> "If Second(now) = nach( n ) Then" <<==
' WScript.Sleep 15*1000 ' alle 1/4 Minute bei ==>> "If Minute(now) = nach( n ) Then" <<==
If Not fso.FileExists( WScript.ScriptFullName ) Then Exit do
Loop
MsgBox "Das wars!", , "0038 :: " & WScript.ScriptName
#########################################################################
>>> input.hta <<<
</html>
<head>
<!--
'v5.B*****************************************************
' File: input.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' ermöglicht die Eingabe von drei Parametern . . .
'
'*********************************************************
zu HTA ==> http://msdn.microsoft.com//workshop/author/hta/hta_node_entry.asp
zu HTML ==> http://selfhtml.org/ bzw. Download
==> http://aktuell.de.selfhtml.org/extras/download.shtml#adressen
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
-->
<HTA:APPLICATION ID="oHTA"
BORDER="none" <!-- -->
INNERBORDER="no" <!-- -->
SCROLL="No" <!-- -->
NAVIGABLE="yes" <!-- -->
APPLICATIONNAME="Service.CD Anmeldung"
>
<!-- <title># input.hta #</title> wird in der Taskleiste angezeigt -->
<title># input.hta #</title>
<style type="text/css">
TD {font-size:12Pt; color:#E0C000; font-style:bold; font-family:Arial, Verdana}
input {font-size:12pt; color:#202060; font-style:bold; font-family:Verdana}
H2 {font-size:18pt; color:#E0C000; font-style:bold; font-family:Verdana}
</style>
</head>
<script language="VBscript">
Const Titel = "input.hta" ' für MsgBox / PopUp
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim WSHnet : Set WSHnet = CreateObject("WScript.NetWork")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
'****************************************
sub Install()
'****************************************
Dim AnzTage
AnzTage = Document.All.xTage.Value
AnzTage = CInt( AnzTage )
If AnzTage = 0 Then MsgBox "Ein Jahr hat """ & AnzTage & """ Tage?" & vbCRLF & vbCRLF & "Es geht doch wohl etwas genauer, oder?!", , "0055 :: " & Titel : Exit Sub
If AnzTage = 333 Then MsgBox "Wieviel Tage hat ein Jahr?! """ & AnzTage & """ Tage?" & vbCRLF & vbCRLF & "Bitte ETWAS Mühe geben!" , , "0056 :: " & Titel : Exit Sub
If AnzTage < 365 Then MsgBox "Könnte ein Jahr ein paar Tage mehr als """ & AnzTage & """ Tage haben?" & vbCRLF & vbCRLF & "Es geht doch wohl etwas genauer, oder?!", , "0057 :: " & Titel : Exit Sub
If AnzTage > 366 Then MsgBox "Könnte ein Jahr ein paar Tage weniger als """ & AnzTage & """ Tage haben?" & vbCRLF & vbCRLF & "Es geht doch wohl etwas genauer, oder?!", , "0058 :: " & Titel : Exit Sub
If AnzTage = 366 Then MsgBox "Sogar ans Schaltjahr gedacht - alle Achtung!" , , "0059 :: " & Titel ' kein : Exit Sub
Dim UName
UName = Document.All.xName.Value
If UName = "" Then MsgBox "Sieh doch mal im Ausweis nach . . . und trage dann bitte deinen RICHTIGEN Namen ein!", , "0063 :: " & Titel : Exit Sub
Dim WochenEnde
If Document.All.opt1.checked Then WochenEnde = "WE"
If Document.All.opt2.checked Then WochenEnde = "keinWE"
If WochenEnde = "" Then MsgBox "Ist nun heute Wochenenede oder nich?!", , "0068 :: " & Titel : Exit Sub
Dim Txt
Txt = " " & "Das waren die Eingaben:"
Txt = Txt & vbCRLF & AnzTage & vbTab & " Tage soll ein Jahr haben."
Txt = Txt & vbCRLF & UName & vbTab & " wurde als Name eingegeben."
Txt = Txt & vbCRLF & WochenEnde & vbTab & " soll heute sein."
MsgBox Txt, , "0075 :: " & Titel
self.close
End Sub ' Install()
'**************************************************************
Sub Schliessen()
'**************************************************************
MsgBox "Dann eben nicht!", , Titel
self.close
End Sub ' Schliessen()
'**************************************************************
Sub document_onKeyDown
'**************************************************************
If window.event.keyCode = 13 Then Call Install()
End Sub
'**************************************************************
Function BeimLaden() ' ruft einige Routinen auf
'**************************************************************
Txt = ""
Txt = Txt & "<fieldset><Legend > Bitte Name eineben: </legend>"
Txt = Txt & "<BR>"
Txt = Txt & " <input Type=""Text"" Name=""xName"" VALUE=""" & WSHnet.UserName & """ > "
Txt = Txt & "<BR><BR>"
Txt = Txt & "</fieldset>"
document.all.NetUserAnzeige.innerHTML = Txt
Txt = ""
Txt = Txt & "<fieldset><Legend align=""Center""> Ist heute Wochenende? </legend>"
<!-- Txt = Txt & "<fieldset><Legend > Ist heute Wochenende? </legend>" -->
Txt = Txt & " <input type=""radio"" name=""R1"" ID=""opt1"" value=""ja""> Ja - heute ist Wochenende!<br>"
Txt = Txt & " <input type=""radio"" name=""R2"" ID=""opt2"" value=""nein""> Nein - ich muss arbeiten!<br>"
<!-- Txt = Txt & " <input checked type=""radio"" name=""R2"" ID=""opt2"" value=""nein""> Nein - ich muss arbeiten!<br>" -->
Txt = Txt & "<BR>"
Txt = Txt & "</fieldset>"
document.all.WeekEnd.innerHTML = Txt
End Function ' BeimLaden()
</script>
<body onLoad="BeimLaden()" bgcolor="#202060" >
<form>
<BR><BR>
<h2 align="center">. . . bitte ausfüllen . . .
<table border="0" cellspacing="10px" width="100%">
<tr>
<td bgcolor=#1d2160 >
<!-- <td bgcolor=#1d2160 align="center" cellspacing="70%" > -->
<fieldset><Legend align="Center"></legend>
Wieviel Tage hat ein Jahr?
<BR><BR>
<input Type="Text" Name="xTage" Value="333" >
<BR><BR>
</fieldset>
<div id=NetUserAnzeige> </div>
<div id=WeekEnd> </div>
<BR>
<INPUT TYPE="Button" Name="StartVBS" value="Start" onClick="Install()" >
<INPUT TYPE="Button" Name="EndeHTA" value="Beenden" onClick="Schliessen()" >
<BR><BR>
</td>
</tr>
</table>
</form>
</body>
</html>
#########################################################################
>>> internettest.vbs <<<
'v3.6***************************************************
' File: InternetTest.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Skript ermittelt, ob das Internet erreichbar ist. Zum
' Testen wird (nur) eine URL benutzt.
'*******************************************************
Option Explicit
Dim oIE
Dim Test, i
Set oIE = CreateObject ("InternetExplorer.Application")
With oIE
' .navigate "http://support.microsoft.com/newsgroups/default.aspx?ICP=GSS3&NewsGroup=microsoft.public.de.german.scripting.wsh&SLCID=DE&scrollnews=m1s9s12"
.navigate "http://google.de"
' .visible = true
.visible = False
do until .readystate=4
wscript.sleep 100
if i > 20 then Exit Do ' entspr. 2sec warten
i = i + 1
loop
Test = .readystate
' If not Test = 4 Then MsgBox "Internet war nicht (schnell genug) erreichbar.", , WScript.Scriptname & " " & Test
' If Test = 4 Then MsgBox "Internet läuft.", , WScript.Scriptname & " " & Test
.quit 'IE wird geschlossen
End with
Set oIE = nothing
If not Test = 4 Then MsgBox "Internet war nicht (schnell genug) erreichbar.", , WScript.Scriptname & " " & Test
If Test = 4 Then MsgBox "Internet läuft.", , WScript.Scriptname & " " & Test
#########################################################################
>>> ip-adresse.vbs <<<
'v2.5***************************************************
' File: ip-dresse.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt den PC-Name und alle IP-Adressen
'*******************************************************
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = "winipcfg.out"
Set Env = WSHShell.Environment("PROCESS")
if Env("OS") = "Windows_NT" then
WSHShell.run "%comspec% /c ipconfig > " & Ziel, 0, True ' ipconfig nach Ziel umleiten
else
WSHShell.run "winipcfg /batch" ,0 ,True ' winipcfg /batch legt autom. "winipcfg.out" an
end if
set WSHShell = nothing
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
AllIPadr = "Dieser Computer heißt " & wshnet.ComputerName & vbCRLF
AllIPadr = AllIPadr & "und hat folgende IP-Adresse(n): " & vbCRLF & vbCRLF
for i1 = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(UCase(TextX(i1)), "IP-ADRESSE") then ' enthält die akt. Zeile ...
IPadr = ""
IPadr = Mid(TextX(i1), InStr(UCase(TextX(i1)), ": ") + 1) ' alles rechts vom ": "
IPadr = trim(IPadr)
If IPadr <> "" Then AllIPadr = AllIPadr + IPadr ' alle IP-Adr.
' If IPadr <> "" Then Exit For ' nur erste IP-Adr.
End If
next
MsgBox AllIPadr, ,WScript.ScriptName
#########################################################################
>>> ip-adresse2.vbs <<<
'v5.1***************************************************
' File: ip-dresse2.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt den PC-Name und alle IP-Adressen
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox AllIPadr(), , WScript.ScriptName ' Function - Aufruf
WScript.Quit
'*******************************************************
Function AllIPadr() ' www.dieseyer.de - v5.2
'*******************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WshSysEnv : Set WshSysEnv = WSHShell.Environment("SYSTEM")
Dim Ziel, TextX, i1, IPAdr
Ziel = "winipcfg.out"
Set WshSysEnv = WSHShell.Environment("PROCESS")
if WshSysEnv("OS") = "Windows_NT" then
WSHShell.run "%comspec% /c ipconfig > " & Ziel, 0, True ' ipconfig nach Ziel umleiten
else
WSHShell.run "winipcfg /batch" ,0 ,True ' winipcfg /batch legt autom. "winipcfg.out" an
end if
set WSHShell = nothing
Dim FileIn : Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
' AllIPadr = "Dieser Computer heißt " & wshnet.ComputerName & vbCRLF
' AllIPadr = AllIPadr & "und hat folgende IP-Adresse(n): " & vbCRLF & vbCRLF
for i1 = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(UCase(TextX(i1)), "IP-ADRESSE") then ' enthält die akt. Zeile ...
IPadr = ""
IPadr = Mid(TextX(i1), InStr(UCase(TextX(i1)), ": ") + 1) ' alles rechts vom ": "
IPadr = trim(IPadr)
If IPadr <> "" Then AllIPadr = AllIPadr + IPadr ' alle IP-Adr.
' If IPadr <> "" Then Exit For ' nur erste IP-Adr.
End If
next
End Function ' AllIPadr() - www.dieseyer.de - v5.2
#########################################################################
>>> ip-adresse3.vbs <<<
'v5.1********************************************************
' File: ip-adresse3.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Damit die IP-Adresse mit IPCONFIG ermittelt werden kann,
' ohne dass eine Schreiboperation auf einen Datenträger
' erfolgt, werden im 'unsichtbaren' Aufruf von
' exechiddenplus.vbs alle IPCONFIG-Ausgaben abgefangen
' und ausgewertet.
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox IPadr, , WScript.ScriptName ' mit Function Aufruf
WScript.Quit
' http://dieseyer.de/scr-html/exechiddenplus.html
' http://dieseyer.de/scr/exechiddenplus.vbs
' so muss die "exechiddenplus.vbs" innen aussehen:
'
' set oArgs = Wscript.Arguments
' For i = 0 to oArgs.Count - 1
' if Instr( oArgs.item(i), " " ) > 0 Then CMD = CMD & """" & oArgs.item(i) & """" & " "
' if not Instr( oArgs.item(i), " " ) > 0 Then CMD = CMD & oArgs.item(i) & " "
' Next
' Set oExec = WScript.CreateObject("WScript.Shell").Exec( CMD )
' Do Until oExec.status : WScript.Sleep 100 : Loop
' WScript.CreateObject("WScript.Shell").Environment( "volatile" )( "Eregbnis" ) = oExec.StdOut.ReadAll()
'**************************************************************
Function IPadr() ' v5.2 - http://dieseyer.de
'**************************************************************
Dim Txt, Tst, i
Dim WshShell : Set WshShell = CreateObject("Wscript.Shell")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
Dim ExecH : ExecH = "exechiddenplus.vbs"
' MsgBox fso.GetAbsolutePathName( ExecH ) & vbCRLF & vbCRLF & "existiert.", , WScript.ScriptName
if not fso.FileExists( ExecH ) Then
MsgBox fso.GetAbsolutePathName( ExecH ) & vbCRLF & vbCRLF & "f e h l t ! ! !", , WScript.ScriptName
Else
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "CScript.exe //NOLOGO " & ExecH & " %comspec% /c ipconfig /all" , 0, true
Txt = WshShell.Environment("volatile")( "Eregbnis" )
Set WshShell = nothing
Tst = Split(Txt, vbCRLF, -1)
' MsgBox "LBound: " & LBound( Tst ) & vbCRLF & "UBound: " & UBound( Tst ) & vbCRLF & Txt, , WScript.ScriptName
For i = LBound( Tst ) to UBound( Tst )
If InStr( Tst( i ), "IP-A" ) > 0 OR InStr( Tst( i ), "IP A" ) > 0 Then
Tst( i ) = Replace( Tst( i ) , vbCR, "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , vbLF, "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , ". .", "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , ". ", "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Mid( Tst( i ) , InStr( Tst( i ) , " : ") + 2 )
Tst( i ) = Replace( Tst( i ) , " ", "" ) ' überflüssige Zeichen entfernen
Tst( i ) = Replace( Tst( i ) , " ", "" ) ' überflüssige Zeichen entfernen
Txt = "---"
' If InStr( Tst( i ), "169.254." ) = 1 Then Txt = "<strike>" & Tst( i ) & " noDHCP</strike>"
If InStr( Tst( i ), "169.254." ) = 1 Then Txt = Tst( i ) & " noDHCP"
' If InStr( Tst( i ), "0.0.0.0" ) = 1 Then Txt = "<strike>" & Tst( i ) & " noDHCP</strike>"
If InStr( Tst( i ), "0.0.0.0" ) = 1 Then Txt = Tst( i ) & " noDHCP"
If InStr( Tst( i ), "53.79.186." ) = 1 Then Txt = Tst( i ) & " Bereich II"
If InStr( Tst( i ), "53.79.187." ) = 1 Then Txt = Tst( i ) & " Bereich VI"
If InStr( Tst( i ), "53.72.161." ) = 1 Then Txt = Tst( i ) & " Labor"
If Txt = "---" Then Txt = Tst( i ) & " OK"
Tst( i ) = Txt
If not IPadr = "" Then IPadr = IPadr & vbCRLF & Tst( i )
If IPadr = "" Then IPadr = Tst( i )
End If
Next
End If
'**************************************************************
End Function ' IPadr() v5.2 - http://dieseyer.de
'**************************************************************
#########################################################################
>>> ip-aus-name.vbs <<<
'v2.5***************************************************
' File: ip-aus-name.vbs
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' Programm ermittelt die IP-Adressen aus einem PC-Name
'*******************************************************
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = "~tmp~.tmp"
PCname = "MeinPC"
PCname = InputBox("Von welchen PC soll die IP-Adr. ermittelt werden?", WScript.ScriptName, PCname)
WSHShell.run ("%comspec% /c Ping " & PCname & " -n 1 -w 500 > " & Ziel), 0, True ' Ping nur einmal ausführen
set WSHShell = nothing
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
for i1 = 0 to ubound(TextX) ' jede Zeile überprüfen
If InStr(UCase(TextX(i1)), "TTL=") Then ' ob TTL= enthalten ist, wenn ja (PING war erfolgreich)
' Bei der Ping-Ausgabe befindet sich hinter der IP-Adresse ein ":" - was links vom ":" steht, ist interessant
EndIPadr = Mid(TextX(i1), 1, InStr(UCase(TextX(i1)), ":") -1 )
' Bei der Ping-Ausgabe befindet sich vor der IP-Adresse ein " " - was rechst vom " " steht, ist die IP-Adr.
IPadr = Mid(EndIPadr, InStrRev(EndIPadr, " ") +1 )
End If
next
if IPadr = "" then MsgBox "Von " & PCname & " konnte die IP-Adr. nicht ermittelt werden!", , WScript.ScriptName
if not IPadr = "" then MsgBox PCname & " hat IP-Adr. " & IPadr , , WScript.ScriptName
#########################################################################
>>> ip-aus-name2.vbs <<<
'*** v4.B *** www.dieseyer.de *******************************
'
' Datei: ip-aus-name2.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Programm ermittelt die IP-Adressen aus einem PC-Name
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim PCName
PCName = wshnet.ComputerName
PCName = "Server01"
PCName = InputBox( vbCRLF & vbCRLF & "Von welchem PC soll IP-Adresse ermittelt werden?", WScript.ScriptName, PCName )
MsgBox IPAdr(PCName), ,WScript.ScriptName
'*** v4.B *** www.dieseyer.de *******************************
Function IPAdr( PC )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim oExec : Set oExec = WshShell.Exec("%comspec% /c Ping " & PC & " -n 1 -w 500" )
Do While Not oExec.StdOut.AtEndOfStream
IPadr = oExec.StdOut.ReadLine
If InStr( IPadr, "TTL=") Then
IPadr = Mid( IPAdr, 1, InStr( IPAdr, ":")-1)
' Löscht alles hinter ":" und das ":"
IPadr = Mid( IPAdr, InStrRev(IPAdr, " ") +1 )
' von Rechts beginnend (InStrRev) wird alles vor dem
' ersten Leerzeichen gelöscht
IPadr = "==>" & IPadr & "<=="
Exit Do
End If
Loop
End Function ' IPAdr( PC )
#########################################################################
>>> ipadr-dns.vbs <<<
'WINS/DNS Query
'By Steve Barton 2/23/09
'On Error Resume Next
strComputer="S010A45SMA002"
strComputer="M010D2500020733"
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration", "WQL", _
wbemFlagReturnImmediately + wbemFlagForwardOnly)
For Each objItem In colItems
strIPAddress = Join(objItem.IPAddress, ",")
strDNSServerSearchOrder = Join(objItem.DNSServerSearchOrder, VBCrLf & Space(40))
If IsNull(objItem.WINSPrimaryServer)=False Then
WScript.Echo "Computer: " & strComputer & VBCrLf & "Description: " & objItem.Description & VBCrLf & "IPAddress: " & strIPAddress & VBCrLf & _
"DNSDomain: " & objItem.DNSDomain & VBCrLf & "DNSServerSearchOrder: " & strDNSServerSearchOrder & VBCrLf & _
"WINSPrimaryServer: " & objItem.WINSPrimaryServer & VBCrLf & "WINSSecondaryServer: " & objItem.WINSSecondaryServer
End If
Next
#########################################################################
>>> ipnetz-loginscr.vbs <<<
'v2.3*****************************************************
' File: ipnetz-loginscr.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Ermittelt das aktuelle IP-Netz und startet je nach
' Netz ein anderes Script.
'
' Sinnvoll als LoginScript in einem Netz mit mehreren
' IP-Netzen.
'*********************************************************
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHEnvX = WSHShell.Environment("Process")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
IPadr1 = "172.21.17." ' IP-Bereich 1
IPadr2 = "192.168.150." ' IP-Bereich 2
IPadr3 = "172.21.19." ' IP-Bereich 3
IPadr4 = "172.21.21." ' IP-Bereich 4
IPadr5 = "10.8.103."
PCname = LCase(wshnet.ComputerName)
Ziel = PCname & ".tmp"
WshShell.run ("%comspec% /c Ping " & PCname & " -n 1 -w 500 > " & Ziel),0,true
' PING nur einmal ausführen
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
TextX = Split(TextX,vbCrLf,1) ' alles gelesene in Zeilen aufteilen
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
if InStr(TextX(i), IPadr1) > 1 then Bereich = "IP1.vbs"
if InStr(TextX(i), IPadr2) > 1 then Bereich = "IP2.vbs"
if InStr(TextX(i), IPadr3) > 1 then Bereich = "IP3.vbs"
if InStr(TextX(i), IPadr4) > 1 then Bereich = "IP4.vbs"
if InStr(TextX(i), IPadr5) > 1 then Bereich = "IP5.vbs"
next
MsgBox Bereich, , WScript.ScriptName
' WshShell.run(Bereich)
#########################################################################
>>> kontext-anzahlzeichenimpfad.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: kontext-anzahlzeichenimpfad.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Erstellt für www.roton.de
'
' Im Kontext-Menü des Windows-Explorers wird ein Eintrag
' hinzugefügt:
' "Anzahl der Zeichen im Pfad ermitteln"
' durch den die Anzahl der Zeichen des Pfades zu einer
' Datei bzw. zu einem Verzeichnis ermittelt und
' angezeigt wird.
'
' Werden mehrer Dateien / Verzeichnisse übergeben, wird nur
' ein Parameter verwendet (der erste oder der letzte).
'
' Beim direkten Aufruf des VBS wird geprüft, ob es bereits
' 'installiert' ist - wenn ja wird eine 'Deinstallation'
' angeboten.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const AnzTeilen = 88 ' wenn die Länge des Pfades "AnzTeilen" übersteigt, wird die Anzeige des Pfades 'geteilt'
Const KontextName = "Anzahl der Zei&chen im Pfad ermitteln"
Dim ContextFunc
Const HKCRShellA = "HKCR\*\shell" ' Erweiterung für Dateien
Const HKCRShellB = "HKCR\Folder\shell" ' Erweiterung für Verzeichnisse
Const VBSVerz = "dieseyer.de" ' wird zu %ProgramFiles%\dieseyer.de; C:\Programme\dieseyer.de
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim DieseyerVerz : DieseyerVerz = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
Dim i, n, Txt, Tst
' Ist das Skript bereits installiert?
If oArgs.Count < 1 AND fso.FileExists( DieseyerVerz ) Then
SkriptDeinst( "049 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' Ist das Skript bereits installiert?
If oArgs.Count < 1 AND Ucase( DieseyerVerz ) = UCase( WScript.ScriptFullName) Then
SkriptDeinst( "055 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' es muss ein Parameter vorhanden sein
If oArgs.Count < 1 Then
SkriptInfo( "061 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' WSHShell.Popup "= = = S T A R T = = =", 2, "065 :: " & WScript.ScriptName
Txt = ""
Txt = oArgs.item( 0 ) ' Der erste Parameter
If Len( Txt ) < AnzTeilen Then
Tst = Txt
Else
Tst = InStr( Mid( Txt, 4 ), "\" ) + 6 ' das erste \ nach "X:\" oder "\\s"
Tst = Mid( Txt, 1, Tst ) ' die ersten Zeichen bis zum \
Tst = Tst & " . . . " & vbCRLF & " . . . "
Tst = Tst & Mid( Txt, InStrRev( Txt, "\" ) - 3 ) ' die Zeichen ab dem letzten \
End If
Tst = "Das sind " & Len( Txt ) & " Zeichen:" & vbCRLF & vbCRLF & Tst
WSHShell.Popup Tst, 10, "080 :: " & WScript.ScriptName
' WSHShell.Popup "= = = E N D E = = =", 1, "082 :: " & WScript.ScriptName
WScript.Quit
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptDeinst( Ttt )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript (neu) installieren." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Skript entfernen und deinstallieren." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Alles lassen, wie es ist . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "102 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call SkriptInst( "ENTFERNEN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "116 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptDeinst( Ttt )
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptInfo( Ttt )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über eine Kontext-Menü-Erweiterung im" & vbCRLF
Txt = Txt & "Windows-Explorer angesprochen werden, um eine Datei" & vbCRLF
Txt = Txt & "oder ein Verzeichnis an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript im Kontext-Menü einfügen." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbNo = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "145 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "154 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptInst( SkriptType )
'************************************************************
' Call SkriptInst( "INSTALLIERN" )
' Call SkriptInst( "ENTFERNEN" )
Dim Txt, Tst
SkriptType = UCase( SkriptType )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz
If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
If SkriptType = "INSTALLIERN" Then
fso.CopyFile WScript.ScriptFullName, Tst, True
Else
fso.CopyFile WScript.ScriptFullName, Tst & " deaktiviert.txt", True
fso.DeleteFile Tst, True
End If
If SkriptType = "INSTALLIERN" Then
WSHShell.RegWrite HKCRShellA & "\AnzZeichenImPfad\", KontextName
WSHShell.RegWrite HKCRShellA & "\AnzZeichenImPfad\Command\", "wscript.exe """ & Tst & """ " & ContextFunc & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\AnzZeichenImPfad\", KontextName
WSHShell.RegWrite HKCRShellB & "\AnzZeichenImPfad\Command\", "wscript.exe """ & Tst & """ " & ContextFunc & " " & chr(34) & "%1" & chr(34)
Else
WSHShell.RegDelete HKCRShellA & "\AnzZeichenImPfad\Command\"
WSHShell.RegDelete HKCRShellA & "\AnzZeichenImPfad\"
WSHShell.RegDelete HKCRShellB & "\AnzZeichenImPfad\Command\"
WSHShell.RegDelete HKCRShellB & "\AnzZeichenImPfad\"
End If
Txt = ""
If SkriptType = "INSTALLIERN" Then
Txt = Txt & "Das Skript """ & WScript.ScriptName & """ ist jetzt in das Kontext-Menü des" & vbCRLF
Txt = Txt & "Windows-Explorer eingetragen und über" & vbCRLF & vbCRLF
Txt = Txt & vbTab & """" & Replace( KontextName, "&", "" ) & """" & vbCRLF & vbCRLF
Txt = Txt & "erreichbar."
Else
Txt = Txt & vbTab & "Das Skript " & vbCRLF & vbCRLF
Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Txt & vbTab & "wurde gelöscht und aus dem Kontext-" & vbCRLF & vbCRLF
Txt = Txt & vbTab & "Menü des Windows-Explorer entfernt."
End If
' MsgBox Txt, , "206 :: " & WScript.ScriptName
WSHShell.Popup Txt, 9, "207 :: " & WScript.ScriptName
End Sub ' SkriptInst( SkriptType )
'*** v8.3 *** www.dieseyer.de *******************************
Sub TempHilfeHta
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "227 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "230 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "231 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "232 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, true)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta
#########################################################################
>>> kontext-besitzerwerden.vbs <<<
'*** v10.B *** www.dieseyer.de *****************************
'
' Datei: kontext-besitzerwerden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Kontext-Menü des Windows-Explorers wird ein Eintrag
' hinzugefügt: "Besitz übernehmen"
'
' Werden mehrer Dateien / Verzeichnisse übergeben, wird nur
' ein Parameter verwendet (der erste oder der letzte).
'
' Beim direkten Aufruf des VBS wird geprüft, ob es bereits
' 'installiert' ist - wenn ja wird eine 'Deinstallation'
' angeboten.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const KontextName1 = "Besitz &übernehmen"
Const ContextFunc1 = "jaNetz"
Dim ContextFunc
Const VBSVerz = "dieseyer.de" ' wird zu %ProgramFiles%\dieseyer.de; C:\Programme\dieseyer.de
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim DieseyerVerz : DieseyerVerz = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
Dim i, n, Txt, Tst
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND fso.FileExists( DieseyerVerz ) Then
SkriptDeinst( "063 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND Ucase( DieseyerVerz ) = UCase( WScript.ScriptFullName) Then
SkriptDeinst( "069 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' es müssen min. zwei Parameter vorhanden sein
If oArgs.Count < 2 Then
SkriptInfo( "075 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
ContextFunc = oArgs.item( 0 ) ' Der erste Parameter entscheidet, ob Netzlaufwerk aufgelöst werden soll oder nicht
If not ContextFunc = ContextFunc1 Then
SkriptInfo( "082 :: " ) ' Sub-Prozedur-Aufruf
' SkriptInfo( "083 :: """ & oArgs.item( 0 ) & """ " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' WSHShell.Popup "= = = S T A R T = = =", 2, "088 :: " & WScript.ScriptName
Txt = "" : Tst = ""
For i = 1 to oArgs.Count - 1 ' hole alle Argumente
Tst = oArgs.item( i )
' MsgBox i & ": " & Tst, , "093 :: "
BesitzerWerden Trim( Tst )
' Exit For ' nur ein übergebener Pfad
Next
' InPutBox "Folgendes wurde durch das Skript" & vbCRLF & vbCRLF & vbTab & """" & WScript.Scriptname & """" & vbCRLF & vbCRLF & "in der Zwischenablage (Clipboard) eingetragen:", "105 :: " & WScript.Scriptname, Tst
' WSHShell.Popup "= = = E N D E = = =", 1, "107 :: " & WScript.ScriptName
WScript.Quit
'*** v10.B *** www.dieseyer.de *****************************
Function BesitzerWerden( Pfad )
'***********************************************************
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Tst
Tst = "%comspec% /c CACLS.EXE """ & Pfad & """ /C /T /E /P " & WSHNet.UserName & ":F &&@echo RC '%errorlevel%'&&@pause"
' MsgBox Tst, , "89 :: "
WSHShell.Run Tst, , True
End Function ' BesitzerWerden( Pfad )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptDeinst( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript (neu) installieren." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Skript entfernen und deinstallieren." & vbCRLF
' Txt = Txt & "[Abbrechen]" & vbTab & "Alles lassen, wie es ist . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Nichts tun . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "177 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call SkriptInst( "ENTFERNEN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "191 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptDeinst( Ttt )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInfo( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über eine Kontext-Menü-Erweiterung im" & vbCRLF
Txt = Txt & "Windows-Explorer angesprochen werden, um eine Datei" & vbCRLF
Txt = Txt & "oder ein Verzeichnis an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript im Kontext-Menü einfügen." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbNo = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "220 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "229 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInst( SkriptType )
'***********************************************************
' Call SkriptInst( "INSTALLIERN" )
' Call SkriptInst( "ENTFERNEN" )
Const HKCRShellA = "HKCR\*\shell" ' Erweiterung für Dateien
Const HKCRShellB = "HKCR\Folder\shell" ' Erweiterung für Verzeichnisse
Dim Txt, Tst
SkriptType = UCase( SkriptType )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz
If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
If SkriptType = "INSTALLIERN" Then
fso.CopyFile WScript.ScriptFullName, Tst, True
Else
fso.CopyFile WScript.ScriptFullName, Tst & " deaktiviert.txt", True
fso.DeleteFile Tst, True
End If
If SkriptType = "INSTALLIERN" Then
WSHShell.RegWrite HKCRShellA & "\KontextName1\", KontextName1
WSHShell.RegWrite HKCRShellA & "\KontextName1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\KontextName1\", KontextName1
WSHShell.RegWrite HKCRShellB & "\KontextName1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
Else
WSHShell.RegDelete HKCRShellA & "\KontextName1\Command\"
WSHShell.RegDelete HKCRShellA & "\KontextName1\"
WSHShell.RegDelete HKCRShellB & "\KontextName1\Command\"
WSHShell.RegDelete HKCRShellB & "\KontextName1\"
End If
Txt = ""
If SkriptType = "INSTALLIERN" Then
Txt = Txt & "Das Skript """ & WScript.ScriptName & """ ist jetzt in das Kontext-Menü des" & vbCRLF
Txt = Txt & "Windows-Explorer eingetragen und über" & vbCRLF & vbCRLF
Txt = Txt & vbTab & """" & Replace( KontextName1, "&", "" ) & """" & vbCRLF & vbCRLF
Txt = Txt & "erreichbar."
Else
Txt = Txt & vbTab & "Das Skript " & vbCRLF & vbCRLF
Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Txt & vbTab & "wurde gelöscht und aus dem Kontext-" & vbCRLF & vbCRLF
Txt = Txt & vbTab & "Menü des Windows-Explorer entfernt."
End If
' MsgBox Txt, , "294 :: " & WScript.ScriptName
WSHShell.Popup Txt, 9, "295 :: " & WScript.ScriptName
End Sub ' SkriptInst( SkriptType )
'*** v8.3 *** www.dieseyer.de ******************************
Sub TempHilfeHta
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "315 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "318 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "319 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "320 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, true)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta
#########################################################################
>>> kontext-commandprompthier.vbs <<<
'*** v3.5 *** www.dieseyer.de *******************************
'
' Datei: kontext-commandprompthier.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Erstellt Kontexteintrag: mit der rechten Maus-Taste
' auf ein Verzeichnis öffnet eine Eingabeaufforderung
' (DOS-Prompt) mit/in diesem Verzeichnis.
'
'************************************************************
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objShell = CreateObject("WScript.Shell")
Set WshSysEnv = WshShell.Environment("SYSTEM")
Text = WSHShell.ExpandEnvironmentStrings("%comspec%")
objShell.RegWrite "HKCR\Folder\Shell\MenuText\Command\", Text & " /k cd " & chr(34) & "%1" & chr(34)
objShell.RegWrite "HKCR\Folder\Shell\MenuText\", "&Command Prompt Hier"
' MsgBox "HKCR\Folder\Shell\MenuText\Command\" & vbCRLF & Text & " /k cd " & chr(34) & "%1" & chr(34)
MsgBox WScript.ScriptName & vbCRLF & vbCRLF & "abgearbeitet.", , WScript.ScriptName
#########################################################################
>>> kontext-erweiterungenanzeigen.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: kontext-erweiterungenanzeigen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' listet die RegKeys, die für die zusätzlichen Optionen
' des Kontextmenüs für Ordner (Klick mit der rechten
' Maus-Taste auf einen Ordner) zuständig sind.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox Kontext( "." ), , WScript.ScriptName
LogEintrag Kontext( "." )
WScript.Quit
'*** v8.3 *** www.dieseyer.de *******************************
Function Kontext( PC )
'************************************************************
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKLM = &H80000002
Dim arrSubKeys, subkey, strValue, Tst
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\default:StdRegProv")
Kontext = Kontext & "WindowsExplorer-Kontextmenü-Erweiterungen für Dateien:" & vbCRLF
oReg.EnumKey HKLM, "SOFTWARE\Classes\*\shell", arrSubKeys
For Each subkey In arrSubKeys
Kontext = Kontext & " " & subkey & vbTab
oReg.GetStringValue HKLM, "SOFTWARE\Classes\*\shell\" & subkey, ,strValue
Tst = strValue : If InStr( Tst, "&" ) > 0 Then Tst = Replace( Tst, "&", "" )
Kontext = Kontext & Tst & vbCRLF
Next
Kontext = Kontext & vbCRLF
Kontext = Kontext & "WindowsExplorer-Kontextmenü-Erweiterungen für Verzeichnisse:" & vbCRLF
oReg.EnumKey HKLM, "SOFTWARE\Classes\Folder\shell", arrSubKeys
For Each subkey In arrSubKeys
Kontext = Kontext & " " & subkey & vbTab
oReg.GetStringValue HKLM, "SOFTWARE\Classes\*\shell\" & subkey, ,strValue
Tst = strValue : If InStr( Tst, "&" ) > 0 Then Tst = Replace( Tst, "&", "" )
Kontext = Kontext & Tst & vbCRLF
Next
End Function ' Kontext()
'*** 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 )
#########################################################################
>>> kontext-pfadinzwischenablage.vbs <<<
'*** v11.4 *** www.dieseyer.de *****************************
'
' Datei: kontext-pfadinzwischenablage.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Kontext-Menü des Windows-Explorers werden zwei Einträge
' hinzugefügt:
' "Pfad (Netzpfad) in die Zwischenablage kopieren"
' aus dem Pfad zu einer Datei / zu einem Verzeichnis
' wird versucht den Netzpfad zu ermitteln und in die
' Zwischenablage kopiert:
' C:\Windows\System32\calc.exe
' (auf "MeinPC.Heim.Netz") wird zu
' \\MeinPC\c$\Windows\System32\calc.exe
' Fehlt c$, bleibts bei C:\Windows\System32\calc.exe
' D:\AutoRun.inf
' (CD-Laufwerk auf "PC003.geht.net") wird zu
' \\PC003\d$\AutoRun.inf
' Fehlt d$, bleibts bei D:\AutoRun.inf
' Z:\Sicherung\08-02-13\wichtig.zip
' (auf "Server1.home.net") wird zu
' \\Server1\Sicherung\08-02-13\wichtig.zip
' \\Server1\Sicherung\08-02-13\wichtig.zip
' (auf "Server1.home.net") bleibt bei
' \\Server1\Sicherung\08-02-13\wichtig.zip
'
' "Pfad (Laufwerk) in die Zwischenablage kopieren"
' der Pfad zu einer Datei / zu einem Verzeichnis wird
' unverändert in die Zwischenablage kopiert.
'
' Werden mehrer Dateien / Verzeichnisse übergeben, wird nur
' ein Parameter verwendet (der erste oder der letzte).
'
' Beim direkten Aufruf des VBS wird geprüft, ob es bereits
' 'installiert' ist - wenn ja wird eine 'Deinstallation'
' angeboten.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const KontextName1 = "Pfad (&Netzpfad) in die Zwischenablage kopieren"
Const KontextName2 = "Pfad (Lauf&werk) in die Zwischenablage kopieren"
Const ContextFunc1 = "jaNetz"
Const ContextFunc2 = "neinNetz"
Dim ContextFunc
Const VBSVerz = "dieseyer.de" ' wird zu %ProgramFiles%\dieseyer.de; C:\Programme\dieseyer.de
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim DieseyerVerz : DieseyerVerz = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
Dim i, n, Txt, Tst
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND fso.FileExists( DieseyerVerz ) Then
SkriptDeinst( "063 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' Ist das Skript bereits installiert?
If oArgs.Count < 2 AND Ucase( DieseyerVerz ) = UCase( WScript.ScriptFullName) Then
SkriptDeinst( "069 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' es müssen min. zwei Parameter vorhanden sein
If oArgs.Count < 2 Then
SkriptInfo( "075 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
ContextFunc = oArgs.item( 0 ) ' Der erste Parameter entscheidet, ob Netzlaufwerk aufgelöst werden soll oder nicht
If not ContextFunc = ContextFunc1 AND not ContextFunc = ContextFunc2 Then
SkriptInfo( "082 :: " ) ' Sub-Prozedur-Aufruf
' SkriptInfo( "083 :: """ & oArgs.item( 0 ) & """ " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' WSHShell.Popup "= = = S T A R T = = =", 2, "088 :: " & WScript.ScriptName
Txt = "" : Tst = ""
For i = 1 to oArgs.Count - 1 ' hole alle Argumente
Tst = oArgs.item( i )
' MsgBox "InStr( " & Tst & ", "":"" ) = " & InStr( Tst, ":" ) & vbCRLF & ContextFunc & "=?=" & ContextFunc1, , "093 :: "
If InStr( Tst, ":" ) = 2 AND ContextFunc = ContextFunc1 Then ' es soll ein Netzwerkpfad ermittelt werden
Tst = NetzPfadVonLwErmitteln( Left( Tst, 1 ) ) ' nur den Lw-Buchstaben
Tst = Tst & Mid( oArgs.item( i ), 3 )
End If
Exit For ' nur ein übergebener Pfad
Next
Call Text2Clipboard( Tst ) ' Txt an die Zwischenablage übergeben
' InPutBox "Folgendes wurde durch das Skript" & vbCRLF & vbCRLF & vbTab & """" & WScript.Scriptname & """" & vbCRLF & vbCRLF & "in der Zwischenablage (Clipboard) eingetragen:", "105 :: " & WScript.Scriptname, Tst
' WSHShell.Popup "= = = E N D E = = =", 1, "107 :: " & WScript.ScriptName
WScript.Quit
'*** v11.4 *** www.dieseyer.de *****************************
Function NetzPfadVonLwErmitteln( Lw )
'***********************************************************
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oDrives : Set oDrives = WSHNet.EnumNetworkDrives
Dim Tst, n
' ist übergebenes Lw ein Pfad?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Lw ) > 2 Then MsgBox Lw & vbCRLF & vbCRLF & Lw, , "123 :: "
If Len( Lw ) > 2 Then NetzPfadVonLwErmitteln = Lw : Exit Function
' ist zweites Zeichen kein Doppelpunkt?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Lw ) = 2 Then If not ":" = Mid( Lw, 2 ) Then MsgBox Lw & vbCRLF & vbCRLF & Lw, , "128 :: "
If Len( Lw ) = 2 Then If not ":" = Mid( Lw, 2 ) Then NetzPfadVonLwErmitteln = Lw : Exit Function
' MsgBox "Function NetzPfadVonLwErmitteln( " & Lw & " )", , "131 :: "
Lw = Left( UCase( Lw ), 1 ) ' nur der Laufwerksbuchstabe
' MsgBox Lw & vbCRLF & vbCRLF & Lw, , "134 :: "
On Error Resume Next
Tst = fso.GetDrive( Lw ).DriveType
' On Error Resume Next
Tst = Int( Tst )
' lokale Festplatte: 2 = fso.GetDrive( Lw ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If 2 = Tst Then
Tst = "\\" & WSHNet.ComputerName & "\" & Lw & "$"
' MsgBox Tst, , "145 :: "
If fso.FolderExists( Tst ) Then NetzPfadVonLwErmitteln = Tst : Exit Function
End If
' verbundenes Netzlaufwerk: 3 = fso.GetDrive( Lw ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Int( 3 ) = Int( Tst ) Then
For n = 0 to oDrives.Count - 1 Step 2
If InStr( oDrives.Item( n ), Lw ) = 1 Then
NetzPfadVonLwErmitteln = oDrives.Item( n + 1 )
' MsgBox oDrives.Item( n ) & vbCRLF & vbCRLF & oDrives.Item( n + 1 ) & vbCRLF & Lw, , "155 :: " & Tst
Exit Function
End If
Next
End If
End Function ' NetzPfadVonLwErmitteln( Lw )
'*** v10.5 *** www.dieseyer.de *****************************
Sub Text2Clipboard( Txt )
'***********************************************************
' http://www.systemscript.com/forumger1/forum_posts.asp?TID=537
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Tst
' ALT: "mshta.exe vbscript:(document.parentwindow.clipboardData.SetData(""text"","" & Txt & ""))(Window.close)"
' NEU: "mshta.exe vbscript:Execute(""document.parentwindow.clipboardData.SetData """"Text"""",""""" & Txt & """"" : self.close"")"
' NEU: "mshta.exe vbscript:Execute(""window.clipboardData.SetData """"Text"""",""""" & Txt & """"" : window.close "")"
' NEU: "mshta.exe vbscript:Execute(""clipboardData.SetData """"Text"""",""""" & Txt & """"" : close"")"
Tst = "mshta.exe vbscript:Execute(""clipboardData.SetData """"Text"""",""""" & Txt & """"" : close"")"
WshShell.Run Tst, , False
' mshta.exe vbscript:Execute("clipboardData.SetData ""Text"",""Text Für die Zwischenablage"" : close")
' mshta.exe vbscript:Execute("document.parentwindow.clipboardData.SetData ""Text"" , ""Text Für die Zwischenablage"" : self.close")
' mshta.exe vbscript:Execute("window.clipboardData.SetData ""Text"",""Text Für die Zwischenablage"" : window.close ")
End Sub ' Text2Clipboard( Txt )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptDeinst( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript (neu) installieren." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Skript entfernen und deinstallieren." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Alles lassen, wie es ist . . . bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "199 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call SkriptInst( "ENTFERNEN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "213 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptDeinst( Ttt )
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInfo( Ttt )
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über eine Kontext-Menü-Erweiterung im" & vbCRLF
Txt = Txt & "Windows-Explorer angesprochen werden, um eine Datei" & vbCRLF
Txt = Txt & "oder ein Verzeichnis an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript im Kontext-Menü einfügen." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbNo = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "242 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If vbYes = Txt Then
Call SkriptInst( "INSTALLIERN" ) ' Sub-Prozedur - Aufruf
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "251 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo
'*** v8.3 *** www.dieseyer.de ******************************
Sub SkriptInst( SkriptType )
'***********************************************************
' Call SkriptInst( "INSTALLIERN" )
' Call SkriptInst( "ENTFERNEN" )
Const HKCRShellA = "HKCR\*\shell" ' Erweiterung für Dateien
Const HKCRShellB = "HKCR\Folder\shell" ' Erweiterung für Verzeichnisse
Dim Txt, Tst
SkriptType = UCase( SkriptType )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz
If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
Tst = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\" & VBSVerz & "\" & WScript.ScriptName
If SkriptType = "INSTALLIERN" Then
fso.CopyFile WScript.ScriptFullName, Tst, True
Else
fso.CopyFile WScript.ScriptFullName, Tst & " deaktiviert.txt", True
fso.DeleteFile Tst, True
End If
If SkriptType = "INSTALLIERN" Then
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage1\", KontextName1
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage2\", KontextName2
WSHShell.RegWrite HKCRShellA & "\PfadInZw.Ablage2\Command\", "wscript.exe """ & Tst & """ " & ContextFunc2 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage1\", KontextName1
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage1\Command\", "wscript.exe """ & Tst & """ " & ContextFunc1 & " " & chr(34) & "%1" & chr(34)
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage2\", KontextName2
WSHShell.RegWrite HKCRShellB & "\PfadInZw.Ablage2\Command\", "wscript.exe """ & Tst & """ " & ContextFunc2 & " " & chr(34) & "%1" & chr(34)
Else
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage1\Command\"
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage1\"
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage2\Command\"
WSHShell.RegDelete HKCRShellA & "\PfadInZw.Ablage2\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage1\Command\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage1\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage2\Command\"
WSHShell.RegDelete HKCRShellB & "\PfadInZw.Ablage2\"
End If
Txt = ""
If SkriptType = "INSTALLIERN" Then
Txt = Txt & "Das Skript """ & WScript.ScriptName & """ ist jetzt in das Kontext-Menü des" & vbCRLF
Txt = Txt & "Windows-Explorer eingetragen und über" & vbCRLF & vbCRLF
Txt = Txt & vbTab & """" & Replace( KontextName1, "&", "" ) & """" & vbCRLF
Txt = Txt & "und" & vbCRLF
Txt = Txt & vbTab & """" & Replace( KontextName2, "&", "" ) & """" & vbCRLF
Txt = Txt & "erreichbar."
Else
Txt = Txt & vbTab & "Das Skript " & vbCRLF & vbCRLF
Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Txt & vbTab & "wurde gelöscht und aus dem Kontext-" & vbCRLF & vbCRLF
Txt = Txt & vbTab & "Menü des Windows-Explorer entfernt."
End If
' MsgBox Txt, , "316 :: " & WScript.ScriptName
WSHShell.Popup Txt, 9, "317 :: " & WScript.ScriptName
End Sub ' SkriptInst( SkriptType )
'*** v8.3 *** www.dieseyer.de ******************************
Sub TempHilfeHta
'***********************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "337 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "340 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "341 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "342 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, true)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta
#########################################################################
>>> kontext-pfadnachzwischenablage.vbs <<<
'*** v7.B *** www.dieseyer.de *******************************
'
' Datei: kontext-pfadnachzwischenablage.vbs
' (aus kontext-unc2clipbrd.vbs)
' Autor: Peter Ackermann
' Auf: www.dieseyer.de
'
' Erweitert das Kontextmenü des WindowsExplorer um die
' Funktionalität
' "UNC Pfad in die Zwischenablage kopieren"
'
'************************************************************
Option Explicit
Dim Text, TextX, oIE', txt
Dim WshShell, String1, String2, Instpath
Set WshShell = CreateObject("WScript.Shell")
TextX = ""
If (WScript.Arguments).Count = 0 Then
unc2clipbrdInstall ' Prozeduraufruf mit WScript.Quit
' WScript.Echo "Ohne Argumente wirds nichts"
' WScript.quit
ElseIf Left((WScript.Arguments).item(0),2) = "\\" Then
TextX = (WScript.Arguments).item(0)
IE( TextX )
ElseIf Mid((WScript.Arguments).item(0), 2, 1) = ":" Then
If Left(((CreateObject("Scripting.FileSystemObject")).getDrive(Left((WScript.Arguments).item(0),2)).ShareName), 2) = "\\" Then
TextX = (CreateObject("Scripting.FileSystemObject")).getDrive(Left((WScript.Arguments).item(0),2)).ShareName & Mid((WScript.Arguments).item(0), 3)
IE( TextX )
Else
TextX = (WScript.Arguments).Item(0)
' WScript.Echo "Kein UNC-Pfad!"
IE( TextX )
End If
End If
WScript.Quit
Function unc2clipbrdInstall
Dim TextX
Dim Instpath : Instpath = "\\server\share\verzeichnis\unc2clipbrd.VBS"
Instpath = "C:\Programme\dieseyer.de\unc2clipbrd.VBS"
Dim RegKey1 : RegKey1 = "HKCR\*\shell\unc2clipbrd\"
Dim RegKey2 : RegKey2 = RegKey1 & "Command\"
Dim RegKey3 : RegKey3 = "HKCU\Software\Classes\Folder\shell\unc2clipbrd\"
Dim RegKey4 : RegKey4 = RegKey3 & "Command\"
Dim String1 : String1 = "UNC-Pfad in die Zwischenablage kopieren"
Dim String2 : String2 = Chr(34) & "WScript" & Chr(34) & Chr(32) & Chr(34) & Instpath & Chr(34) & Chr(32) & Chr(34) & "%1" & Chr(34)
TextX = ""
TextX = TextX & "Soll das Skript" & vbCRLF & vbCRLF
TextX = TextX & vbTab & WScript.ScriptFullName & vbCRLF & vbCRLF
TextX = TextX & "installiert oder ggf. deinstalliert werden?" & vbCRLF & vbCRLF
TextX = TextX & "[Ja]" & vbTab & vbTab & "Installieren" & vbCRLF
TextX = TextX & "[Nein]" & vbTab & vbTab & "Deinstallieren" & vbCRLF
TextX = TextX & "[Abbrechen]" & vbTab & "Nichts tun" & vbCRLF
TextX = MsgBox( TextX, vbYesNoCancel )
If TextX = vbNo Then
On Error Resume Next ' Falls doch nichts installiert gewesen sein sollte
WshShell.RegDelete RegKey2
WshShell.RegDelete RegKey1
WshShell.RegDelete RegKey4
WshShell.RegDelete RegKey3
CreateObject("Scripting.FileSystemObject").DeleteFile Instpath, True
MsgBox "Alles von """ & WScript.ScriptName & """ entfernt."
WScript.Quit
End If ' TextX = vbNo Then
If TextX = vbYes Then
WshShell.RegWrite RegKey1, String1, "REG_SZ"
WshShell.RegWrite RegKey2, String2, "REG_SZ"
WshShell.RegWrite RegKey3, String1, "REG_SZ"
WshShell.RegWrite RegKey4, String2, "REG_SZ"
CreateObject("Scripting.FileSystemObject").CopyFile WScript.ScriptFullName, Instpath, True
MsgBox "Die Erweiterung des Kontextmenüs " & vbCRLF & vbCRLF & vbTab & """" & String1 & """" & vbCRLF & vbCRLF & "ist jetzt verfügbar."
WScript.Quit
End If ' TextX = vbYes Then
MsgBox "Denn eben nicht!" : WScript.Quit
End Function ' unc2clipbrdInstall
Function CheckRegKey(CheckKey)
Dim Wert, Fehler
On Error Resume Next
Wert=WshShell.RegRead(CheckKey)
Fehler=Err
Err.Clear
On Error Goto 0
CheckRegKey=Fehler=0
End Function
Sub IE( UNCPfad )
' MsgBox "UNCPfad: " & UNCPfad
Set oIE = WScript.CreateObject("InternetExplorer.Application")
oIE.navigate "about:blank"
oIE.visible = 0
Do While (oIE.Busy)
WScript.Sleep 50
Loop
' oIE.Document.parentWindow.clipboardData.setData "text", Chr(60) & UNCPfad & Chr(62)
oIE.Document.parentWindow.clipboardData.setData "text", UNCPfad
' txt = oIE.document.parentWindow.clipboarddata.getData("text")
' MsgBox txt, ,"Zwischenablage:"
oIE.Quit
End Sub ' IE( UNCPfad )
#########################################################################
>>> kontext-unc2clipbrd.vbs <<<
'*** v7.B *** www.dieseyer.de *******************************
'
' Datei: kontext-unc2clipbrd.vbs
' Autor: Peter Ackermann
' Auf: www.dieseyer.de
'
' Erweitert das Kontextmenü des WindowsExplorer um die
' Funktionalität
' "UNC Pfad in die Zwischenablage kopieren"
'************************************************************
Option Explicit
Dim Text, TextX, oIE', txt
Dim WshShell, String1, String2, Instpath
Set WshShell = CreateObject("WScript.Shell")
TextX = ""
If (WScript.Arguments).Count = 0 Then
unc2clipbrdInstall ' Prozeduraufruf mit WScript.Quit
' WScript.Echo "Ohne Argumente wirds nichts"
' WScript.quit
ElseIf Left((WScript.Arguments).item(0),2) = "\\" Then
TextX = (WScript.Arguments).item(0)
IE( TextX )
ElseIf Mid((WScript.Arguments).item(0), 2, 1) = ":" Then
If Left(((CreateObject("Scripting.FileSystemObject")).getDrive(Left((WScript.Arguments).item(0),2)).ShareName), 2) = "\\" Then
TextX = (CreateObject("Scripting.FileSystemObject")).getDrive(Left((WScript.Arguments).item(0),2)).ShareName & Mid((WScript.Arguments).item(0), 3)
IE( TextX )
Else
TextX = (WScript.Arguments).Item(0)
' WScript.Echo "Kein UNC-Pfad!"
IE( TextX )
End If
End If
WScript.Quit
Function unc2clipbrdInstall
Dim TextX
Dim Instpath : Instpath = "\\server\share\verzeichnis\unc2clipbrd.VBS"
Instpath = "C:\Programme\dieseyer.de\unc2clipbrd.VBS"
Dim RegKey1 : RegKey1 = "HKCR\*\shell\unc2clipbrd\"
Dim RegKey2 : RegKey2 = RegKey1 & "Command\"
Dim RegKey3 : RegKey3 = "HKCU\Software\Classes\Folder\shell\unc2clipbrd\"
Dim RegKey4 : RegKey4 = RegKey3 & "Command\"
Dim String1 : String1 = "UNC-Pfad in die Zwischenablage kopieren"
Dim String2 : String2 = Chr(34) & "WScript" & Chr(34) & Chr(32) & Chr(34) & Instpath & Chr(34) & Chr(32) & Chr(34) & "%1" & Chr(34)
TextX = ""
TextX = TextX & "Soll das Skript" & vbCRLF & vbCRLF
TextX = TextX & vbTab & WScript.ScriptFullName & vbCRLF & vbCRLF
TextX = TextX & "installiert oder ggf. deinstalliert werden?" & vbCRLF & vbCRLF
TextX = TextX & "[Ja]" & vbTab & vbTab & "Installieren" & vbCRLF
TextX = TextX & "[Nein]" & vbTab & vbTab & "Deinstallieren" & vbCRLF
TextX = TextX & "[Abbrechen]" & vbTab & "Nichts tun" & vbCRLF
TextX = MsgBox( TextX, vbYesNoCancel )
If TextX = vbNo Then
On Error Resume Next ' Falls doch nichts installiert gewesen sein sollte
WshShell.RegDelete RegKey2
WshShell.RegDelete RegKey1
WshShell.RegDelete RegKey4
WshShell.RegDelete RegKey3
CreateObject("Scripting.FileSystemObject").DeleteFile Instpath, True
MsgBox "Alles von """ & WScript.ScriptName & """ entfernt."
WScript.Quit
End If ' TextX = vbNo Then
If TextX = vbYes Then
WshShell.RegWrite RegKey1, String1, "REG_SZ"
WshShell.RegWrite RegKey2, String2, "REG_SZ"
WshShell.RegWrite RegKey3, String1, "REG_SZ"
WshShell.RegWrite RegKey4, String2, "REG_SZ"
CreateObject("Scripting.FileSystemObject").CopyFile WScript.ScriptFullName, Instpath, True
MsgBox "Die Erweiterung des Kontextmenüs " & vbCRLF & vbCRLF & vbTab & """" & String1 & """" & vbCRLF & vbCRLF & "ist jetzt verfügbar."
WScript.Quit
End If ' TextX = vbYes Then
MsgBox "Denn eben nicht!" : WScript.Quit
End Function ' unc2clipbrdInstall
Function CheckRegKey(CheckKey)
Dim Wert, Fehler
On Error Resume Next
Wert=WshShell.RegRead(CheckKey)
Fehler=Err
Err.Clear
On Error Goto 0
CheckRegKey=Fehler=0
End Function
Sub IE( UNCPfad )
' MsgBox "UNCPfad: " & UNCPfad
Set oIE = WScript.CreateObject("InternetExplorer.Application")
oIE.navigate "about:blank"
oIE.visible = 0
Do While (oIE.Busy)
WScript.Sleep 50
Loop
oIE.Document.parentWindow.clipboardData.setData "text", Chr(60) & UNCPfad & Chr(62)
' txt = oIE.document.parentWindow.clipboarddata.getData("text")
' MsgBox txt, ,"Zwischenablage:"
oIE.Quit
End Sub ' IE( UNCPfad )
#########################################################################
>>> lastlogon.vbs <<<
'v3.4***************************************************
' File: LastLogon.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt den zuletzt angemeldeten Benutzer
'*******************************************************
Option Explicit
Dim WshShell, WSHNet, fso, ObjReg, ObjRemote, KeyX, Text, RootKey, oVal
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
If (fso.FileExists("REGOBJ.DLL")) Then ' Regobj.dll registrieren (erfordert AdminRechte)
Text = "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" ' damit läßt sich besser auf die registry zugreifen
WshShell.Run (Text),,TRUE ' muß im gleichen Verzeichnis wie das Script stehen
Set ObjReg = WScript.CreateObject("RegObj.Registry")
Else
MsgBox "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" & vbTab & " konnte nicht aufgerufen werden!", , WScript.ScriptName
WScript.Quit
End If
Text = "Von welchem Computer soll ermittelt werden, " & vbCRLF
Text = Text & "wer als letzter angemeldet war bzw. aktuell angemeldet ist?"
Text = InputBox (Text, WScript.ScriptName, "rs")
Set ObjRemote = objReg.RemoteRegistry(wshnet.ComputerName) ' Objekt zeigt auf aktuellen PC (REGOBJ.DLL)
Set ObjRemote = objReg.RemoteRegistry( Text ) ' Objekt zeigt auf (Remote-) PC (REGOBJ.DLL)
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\Winlogon"
Text = "Am Computer " & Text & " war zuletzt folgender Benutzer angemeldet:" & vbCRLF & vbCRLF & vbTab & vbTab & vbTab
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
if not err.Number = 0 then Text = Text & " ==> konnte nicht abgefragt werden!"
For Each oVal In RootKey.Values ' Auflistung Werte
if oVal.Name = "DefaultUserName" then
if not oVal.Name = "DefaultUserName" = "" then Text = Text & oVal.Value
End If
Next
On Error GoTo 0
MsgBox " " & Text , , WScript.ScriptName
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
#########################################################################
>>> laufwerk-c.vbs <<<
'*** v5.A*** www.dieseyer.de *******************************
'
' Datei: laufwerk-c.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Zeigt Infos zu Laufwerk C:.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt
Txt = FestplattenTest( "C:" ) ' mit Function-Aufruf
Txt = "Auf Laufwerk C: sind " & Txt & "."
MsgBox Txt, , "16 :: " & WScript.ScriptName
'*** v5.A*** www.dieseyer.de *******************************
Function FestplattenTest( Lw )
'************************************************************
Dim WshShell, fso, FileOut, DriveList, i, Text1, Text3
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set DriveList = fso.Drives
Lw = Replace( Lw, "\", "" )
Lw = Replace( Lw, ":", "" )
For Each i in DriveList
If i.DriveLetter = Lw AND i.IsReady Then
Text3 = ""
Text3 = FormatNumber(i.FreeSpace/1024/1024/1024, 1) & "GB" & " " & "von" & " "
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?GB" & " " & "von" & " "
Text3 = ""
Text3 = FormatNumber(i.TotalSize/1024/1024/1024, 1) & "GB" & " " & " frei"
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?GB" & " " & " frei"
FestplattenTest = Text1
End If
Next
' MsgBox FestplattenTest, , "41 :: " & WScript.ScriptName
End Function ' FestplattenTest( Lw )
#########################################################################
>>> laufwerkliste.vbs <<<
'*** v2.9*** www.dieseyer.de *******************************
'
' Datei: laufwerkliste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Listet alle lokalen Laufwerke auf & erstellt Log-Datei.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WshShell, fso, FileOut, DriveList, i, Text1, Text2, Text3
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set DriveList = fso.Drives
' Protokoll in Datei schreiben
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".log", 8, true) ' Datei zum Schreiben öffnen (notfals anlegen)
fileOut.WriteLine(vbCRLF & now() & " Protokoll von " & WScript.ScriptName & ": ")
For Each i in DriveList
if 0 = i.DriveType Then Text1 = "??? " & vbTab & i.DriveLetter & ": " & vbTab
if 1 = i.DriveType Then Text1 = "Disk-Lw." & vbTab & i.DriveLetter & ": " & vbTab
if 2 = i.DriveType Then Text1 = "Festpl. " & vbTab & i.DriveLetter & ": " & vbTab
if 3 = i.DriveType Then Text1 = "Netz-Lw." & vbTab & i.DriveLetter & ": " & vbTab
if 4 = i.DriveType Then Text1 = "CD-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
if 5 = i.DriveType Then Text1 = "RAM-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
If i.IsReady Then
Text3 = ""
Text3 = FormatNumber(i.FreeSpace/1024/1024, 1) & "MB" & vbTab & "von" & vbTab
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?MB" & vbTab & "von" & vbTab
Text3 = ""
Text3 = FormatNumber(i.TotalSize/1024/1024, 1) & "MB" & vbTab & " frei"
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?MB" & vbTab & " frei"
End If
fileOut.WriteLine(Text1)
Text2 = Text2 & Text1 & vbCRLF
Next
FileOut.Close
Set FileOut = Nothing
MsgBox Text2, , WScript.ScriptName
#########################################################################
>>> laufwerkliste2.vbs <<<
'*** v4.A *** www.dieseyer.de *******************************
'
' Datei: laufwerkliste2.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Listet alle lokalen Laufwerke auf
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox LwListe(), , WScript.ScriptName
WScript.Quit
'*** v4.A *** www.dieseyer.de *******************************
Function LwListe()
'************************************************************
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim DriveList : Set DriveList = fso.Drives
Dim i
Dim Text1, Text3
For Each i in DriveList
if 0 = i.DriveType Then Text1 = "??? " & vbTab & i.DriveLetter & ": " & vbTab
if 1 = i.DriveType Then Text1 = "Disk-Lw." & vbTab & i.DriveLetter & ": " & vbTab
if 2 = i.DriveType Then Text1 = "Festpl. " & vbTab & i.DriveLetter & ": " & vbTab
if 3 = i.DriveType Then Text1 = "Netz-Lw." & vbTab & i.DriveLetter & ": " & vbTab
if 4 = i.DriveType Then Text1 = "CD-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
if 5 = i.DriveType Then Text1 = "RAM-Lw. " & vbTab & i.DriveLetter & ": " & vbTab
If i.IsReady Then
Text3 = ""
Text3 = FormatNumber(i.FreeSpace/1024/1024, 1) & "MB" & vbTab & "von" & vbTab
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?MB" & vbTab & "von" & vbTab
Text3 = ""
Text3 = FormatNumber(i.TotalSize/1024/1024, 1) & "MB" & vbTab & " frei"
if Text3 <> "" then Text1 = Text1 & Text3
if Text3 = "" then Text1 = Text1 & "?-?-?MB" & vbTab & " frei"
End If
LwListe = LwListe & Text1 & vbCRLF
Next
End Function ' LwListe()
#########################################################################
>>> laufwerksbuchstabefrei.vbs <<<
'*** v3.A*** www.dieseyer.de *******************************
'
' Datei: laufwerksbuchstabefrei.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Gibt den ersten freien Laufwerksbuchstaben zurück.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox "Erster freier Laufwerksbuchstabe: """ & LwFrei() & """ ", , Wscript.ScriptName
WScript.Quit
'*** 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()
#########################################################################
>>> lfdprozess-kill.vbs <<<
'*** v5.1*** www.dieseyer.de *******************************
'
' Datei: LfdProzess-Kill.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Das Skript erwartet 3 oder 4 Parameter
' ( ProzessName MeldungsText AnzahlDerMeldung Kill)
' LfdProzess-Kill.vbs IExplore.exe "Bitte den Internetexplorer beenden!" 3
' LfdProzess-Kill.vbs IExplore.exe "Bitte den Internetexplorer beenden!" 3 KilL
'
' Das Skript prüft alle 30sec, ob die Anwendung noch läuft -
' wenn ja, fordert es den Anwender mit "MeldungsText" auf, die
' Anwendung zu beenden.
' Ist die Anwendung nach "AnzahlDerMeldung" immer noch aktiv,
' beendet sich das Skript ohne Aktion. Enthält der 4. Parameter
' "KILL", wird die Anwendung bzw. sein Prozess beendet
' (ge-kill-t, abgeschossen).
'
'************************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WshSysEnv : Set WshSysEnv = WSHShell.Environment("SYSTEM")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim Txt, i
Dim ProzName, ProzMsg, TestAnz, ProzKill
Dim LogDatei
If oArgs.Count < 3 OR oArgs.Count > 4 then
MsgBox "Falsche Anzahl von Argumenten - SkriptEnde", 4096, oArgs.Count & " - " & WScript.ScriptName
WScript.Quit
End If
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
' MsgBox oArgs.item(i), , i
if i = 0 then ProzName = oArgs.item(i)
if i = 1 then ProzMsg = oArgs.item(i)
if i = 2 then TestAnz = oArgs.item(i)
if i = 3 then ProzKill = oArgs.item(i)
Next
LogDatei = "c:\" & fso.GetBaseName( WScript.ScriptName ) & ".log"
LogDatei = "c:\" & ProzName & ".log"
' LogEintrag( "" ) ' neue Log anlegen
LogEintrag( WScript.ScriptFullName & " - Aufruf" )
ProzKill = UCase( ProzKill )
ProzName = UCase( ProzName )
TestAnz = CInt( TestAnz )
i = 1
Do
' MsgBox i & vbTab & LfdProzessTest( ProzName ), , TestAnz
Txt = LfdProzessTest( ProzName ) ' Function Aufruf
If Txt = 0 Then
LogEintrag( ProzName & " läuft z.Z. nicht." )
Exit Do
Else
LogEintrag( ProzName & " (" & Txt & ") läuft z.Z. - angemeldeter User: " & WSHNet.UserName )
If i = TestAnz Then WSHShell.Popup vbTab & vbTab & vbTab & "! ! ! A C H T U N G ! ! !" & vbCRLF & vbCRLF & "Die Anwendung wird in 30sec automatisch geschlossen!" & vbCRLF & vbCRLF & "Durch die Bestaetigung des OK Button wird die Applikation sofort ohne speichern geschlossen" & vbCRLF & vbCRLF & ProzMsg, 30, i & " - " & ProzName, 4096+48
If i <> TestAnz Then MsgBox ProzMsg, 4096, i & " - " & ProzName
End If
i = i + 1
If i > TestAnz Then
If not Txt = 0 AND ProzKill = "KILL" Then
Txt = LfdProzessKill( Txt ) ' Function Aufruf
LogEintrag( Txt )
Else
If not Txt = 0 Then LogEintrag( ProzName & " wurde nicht von " & WSHNet.UserName & " beenedet." )
If Txt = 0 Then LogEintrag( ProzName & " läuft z.Z. nicht." )
End If
Exit Do
End If
WScript.Sleep 1000*3
Loop
LogEintrag( WScript.ScriptFullName & " - beendet" & vbCRLF )
' WSHShell.Run "notepad " & LogDatei
WScript.Quit
'**************************************************************
Sub LogEintrag( LogTxt )
'**************************************************************
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut
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 )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v5.1*** www.dieseyer.de *******************************
Function LfdProzessTest( ProzessName )
'***********************************************************
Dim Txt, objWMIService, colItems, objItem
ProzessName = UCase( ProzessName )
LfdProzessTest = 0
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_Process",,48)
For Each objItem in colItems
Txt = UCase( objItem.Description )
If Txt = ProzessName Then
' LogEintrag( "Description: " & objItem.Description )
' LogEintrag( "Name: " & objItem.Name )
' LogEintrag( "ProcessId: " & objItem.ProcessId )
LfdProzessTest = objItem.ProcessId
' LogEintrag( "Handle: " & objItem.Handle )
' LogEintrag( "SessionId: " & objItem.SessionId )
' LogEintrag( "Status: " & objItem.Status )
' LogEintrag( "WindowsVersion: " & objItem.WindowsVersion )
End If
Next
End Function ' LfdProzessTest( ProzessName )
'*** v5.1*** www.dieseyer.de *******************************
Function LfdProzessKill( ProzessID )
'**************************************************************
Dim oProc, oInstance
Set oProc = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!//." ).ExecQuery ("Select * from Win32_Process " & "Where ProcessID =" & ProzessID)
For Each oInstance in oProc
oInstance.Terminate 0
LfdProzessKill = "ProcessId: " & oInstance.ProcessID & " (" & oInstance.Name & ") wurde beendet."
Next
End Function ' LfdProzessKill( ProzessID )
#########################################################################
>>> linkinsendto.vbs <<<
'*** v3.B*** www.dieseyer.de *******************************
'
' Datei: linkinsendto.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Befindet sich die Function-Prozedur 'AutoStartLink' in einem
' Skript, wird
'
' beim ersten Aufruf
' - das Skript in den Ordner "c:\programme\dieseyer.de\" kopiert
' - ein Link (mit '-Install'-Parameter) zu diesem Skript im
' Autostart-Ordner (All Users) angelegt, damit nach der
' User-Anmeldung ein Link im (User abhängigen) 'SendTo'
' -Ordner eingefügt wird.
' - ein Link zu diesem Skript im 'SendTo'-Ordner (des zur Zeit
' angemeldeten User) angelegt.
'
' beim Aufruf durch Autostart
' - (mit '-Install'-Parameter) wird ein Link zu diesem Skript im
' 'SendTo'-Ordner (des zur Zeit angemeldeten User) angelegt.
'
' beim Aufruf durch 'Senden an' bzw. 'SendTo':
' Man kann jetzt im Explorer Datei(en) markieren (und dann
' durch Klicken mit der rechten Maus-Taste und über 'Senden
' an') die markierten Dateien an das Skript übergeben.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim i, Text, oArgs, SendToLink
Set oArgs = Wscript.Arguments ' Argumente bereit stellen
SendToLink = "TEST Link In SendToText"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo SendToLink ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then
Text = Left( UCase(oArgs.item(i)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Skript wurde mit Parameter "-S" oder "-I" (bzw. -setup oder -install)
' aufgerufen; die AutoStartLink-Prozedur endet mit WScript.Quit
End If
ReDim Preserve arrTest(i)
arrTest(i) = oArgs.item(i)
Next
' arrSort = bubblesort(arrTest) ' function - Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = "Folgende Argumente wurden an das Skript übergeben:"
for i = 0 to ubound(arrTest)
Text = Text & vbCRLF & vbTab & i+1 & ". Argument: " & arrTest(i)
next
MsgBox Text, , WScript.ScriptName
WScript.Quit
'*** v3.B*** www.dieseyer.de *******************************
Sub SkriptInfo( SendToLink )
'***********************************************************
Dim Text
Dim WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Entweder ein oder mehrere Dateien bzw. Verzeichnisse " & vbCRLF
Text = Text & "mit der 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( SendToLink )
'*** v3.B*** www.dieseyer.de *******************************
Function AutoStartLink( SendToLink )
'***********************************************************
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 )
#########################################################################
>>> logdatei.vbs <<<
'*** v9.5 *** www.dieseyer.de *******************************
'
' Datei: logdatei.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Prozeduren, um LOG-Dateien zu erstellen / fortzuschreiben:
'
' trace32.exe stammt aus
' http://support.microsoft.com/kb/272436
' http://www.microsoft.com/technet/sms/20/downloads/tools/sp2_tools_help.mspx
' zeigt sehr lange LOG-Einträge (einer Zeile) in einem
' (Status-) Fenster und in der Statuszeile die Dauer vom
' Start der LOG-Datei bis zur aktuellen LOG-Zeile.
'
' Sub LogTrace32( LogTxt )
' Durch Filter wird aus LogTxt ein errType generiert.
' Ist LogTxt leer ( "" ), wird eine enue LOG-Datei erstellt
'
' Sub LogEintrag( LogTxt )
' LOG-Dateien für baretail.exe
' Ist LogTxt leer ( "" ), wird eine neue LOG-Datei erstellt
' (http://baremetalsoft.com/baretail)
'
' Sub LogText( LogTxt )
' ein Einzeiler
'
'
' Die Zeilennummerm (z.B. "029 :: " für LOG-Dateien können
' in VBS-Dateien komfortabel mit
' http://dieseyer.de/scr-html/sendenan-sicherung.html
' angepasst werden.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim SleepDauer
LogText "040 :: " & now() & " - Aufruf der Sub-Prozedur ""LogText"" "
Dim LogDatei : LogDatei = "c:\log.log"
LogEintrag "043 :: Aufruf der Sub-Prozedur ""LogEintrag"" "
LogDatei = "" ' Dadurch wird innerhalb von LogTrace32() die (Ziel-) LogDatei festgelegt
LogTrace32 "047 :: " & WScript.ScriptFullName & " wurde soeben gestartet"
LogTrace32 "048 :: Aufruf der Sub-Prozedur ""LogTrace32"" "
LogTrace32 "049 :: Aufruf faiLED der "" "
LogTrace32 "050 :: Aufruf discarded der "" "
LogTrace32 "051 :: Aufruf ERROR der "" "
LogTrace32 "052 :: Aufruf FEhler der "" "
LogTrace32 "053 :: Aufruf Warning der "" "
SleepDauer = 11
LogTrace32 "055 :: Neue LOG-Datei nach " & SleepDauer & "s, weil Parameter für ""Sub LogTrace32( """" )"" (also leer) ist." ' neue LOG-Datei mit erste Zeile als normale Zeile
WScript.Sleep SleepDauer * 1000
LogTrace32 ""
LogTrace32 "058 :: Aufruf faiLED der "" "
LogTrace32 "059 :: Aufruf discarded der "" "
LogTrace32 "060 :: Aufruf ERROR der "" "
LogTrace32 "061 :: Aufruf FEhler der "" "
LogTrace32 "062 :: Aufruf Warning der "" "
LogTrace32 "063 :: Aufruf Achtung der Sub-Prozedur ""LogTrace32"" "
LogTrace32 "064 :: Aufruf !not exist! der "" "
LogTrace32 "065 :: Aufruf !Fehlt! der "" "
LogTrace32 "066 :: Aufruf !Fehlt: der Sub-Prozedur! ""LogTrace32"" "
LogTrace32 "067 :: Aufruf !existiert nicht! der "" "
LogTrace32 "068 :: Aufruf !nicht gefunden! der "" "
LogTrace32 "069 :: Aufruf !unable der Sub-Prozedur ""LogTrace32"" "
LogTrace32 "070 :: Aufr Could not get "" "
LogTrace32 "071 :: Aufr Could not specified Prozedur ""LogTrace32"" "
WScript.Quit
'*** v8.4 *** www.dieseyer.de *******************************
Sub LogTrace32( LogTxt )
'************************************************************
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="04:00: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
' 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 = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut, LogDateiX, ErrType, Tst, Nr
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable LogDatei nicht außerhalb der Prozedur definiert
If Err.Number <> 0 Then LogDateiX = WScript.ScriptFullName & "-trc32.log"
On Error Goto 0
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & "-trc32.log"
If LogTxt = "" Then ' eine neue .LOG-Datei wird erstellt, eine vorhandene überschrieben
fso.OpenTextFile( LogDateiX, 2, true).Close
Exit Sub
End If
Tst = UCase( Logtxt ) : ErrType = 1
If InStr( Tst, "FAILED" ) Then ErrType = 3
If InStr( Tst, "ERROR" ) Then ErrType = 3
If InStr( Tst, "FEHLER" ) Then ErrType = 3
If InStr( Tst, "MISSING" ) Then ErrType = 2
If InStr( Tst, "FEHLT:" ) Then ErrType = 2
If InStr( Tst, "EXISTIERT NICHT" ) Then ErrType = 2
If InStr( Tst, "WARNING" ) Then ErrType = 2
If InStr( Tst, "ACHTUNG" ) Then ErrType = 2
If InStr( Tst, "DISCARDED" ) Then ErrType = 2
If InStr( Tst, "NOT EXIST" ) Then ErrType = 2
If InStr( Tst, "NICHT GEFUNDEN" ) Then ErrType = 2
If InStr( Tst, "NOT SPECIFIED" ) Then ErrType = 2
If InStr( Tst, "UNDEFINED" ) Then ErrType = 2
If InStr( Tst, "NICHT DEFINIERT" ) Then ErrType = 2
If InStr( Tst, "UNDEFINIERT" ) Then ErrType = 2
If InStr( Tst, "UNABLE" ) Then ErrType = 2
If InStr( Tst, "NOT GET" ) Then ErrType = 2
Dim objTimeZone, colTimeZone, TimeZoneBias
Set colTimeZone = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select * from Win32_TimeZone")
For Each objTimeZone in colTimeZone
TimeZoneBias = objTimeZone.Bias
Next
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
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
Tst = Timer()
If InStr( Tst, "," ) = 0 Then Tst = "111,00"
If InStr( Tst, "," ) > 0 Then Tst = Mid( Tst, InStr( Tst, "," ), 4 )
Tst = Replace( Tst, "," , ".")
If Len( Tst ) < 3 Then Tst = Tst & "0"
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Time() & Tst & "+-" & TimeZoneBias & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & WScript.ScriptName & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
fso.OpenTextFile( LogDateiX, 8, true).WriteLine ( LogTxt )
End Sub ' LogTrace32( LogTxt )
'*** 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 Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log"
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 )
'*** v3.9 *** www.dieseyer.de *******************************
Sub LogText( LogTxt )
'************************************************************
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( WScript.ScriptFullName & ".log", 8, true ).WriteLine ( LogTxt )
End Sub ' LogText( LogTxt )
#########################################################################
>>> login2server.hta <<<
</html>
<head>
<!--
'v5.5*************************************************************************
' File: Login2Server.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' Ermöglicht die Eingabe von Benutzer und Passwort für die
' Anmeldung an verschiedene Server einer anderen Domäne
'
'*****************************************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
-->
<HTA:APPLICATION ID="oHTA"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
APPLICATIONNAME="Service.CD Anmeldung"
>
<title>Login 2 Server</title>
<style type="text/css">
TD {font-size:13Pt; color:#E0C000; font-style:bold; font-family:Verdana}
input {font-size:13pt; color:#202060; font-style:bold; font-family:Verdana}
H2 {font-size:24pt; color:#E0C000; font-style:bold; font-family:Verdana}
</style>
</head>
<script language="VBscript">
Option Explicit
Const Titel = "Login 2 Server"
Dim WSHNet : Set WSHNet = CreateObject("WScript.Network")
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
'-----------------------------------------------------------------------------
' Start - Einstellungen
'-----------------------------------------------------------------------------
' Wenn LgOn(3,x) leer ist, wird der eingegebene UserName verwendet -
' sonst z.B. LgOn(3,3)="server-DieSeyer"
' net use K: \\Server1\Share /user:LogDom\LogName
ReDim Preserve LgOn(5, 0) : LgOn(0,0)= "T:" : LgOn(1,0)= "\\ServerX\transfer" : LgOn(2,0)="InternX" : LgOn(3,0)=""
' ReDim Preserve LgOn(5, 1) : LgOn(0,1)= "R:" : LgOn(1,1)= "\\Server2\C$" : LgOn(2,1)="LogDom" : LgOn(3,1)=""
' ReDim Preserve LgOn(5, 2) : LgOn(0,2)= "S:" : LgOn(1,2)= "\\Server2\D$" : LgOn(2,2)="LogDom" : LgOn(3,2)=""
' ReDim Preserve LgOn(5, 3) : LgOn(0,3)= "L:" : LgOn(1,3)= "\\Server1\D$" : LgOn(2,3)="LogDom" : LgOn(3,3)="server-DieSeyer"
'-----------------------------------------------------------------------------
Dim i, Tx, Td, Text
Dim UserPwd, UserName
'*****************************************************************************
Function BeimLaden() ' ruft einige Routinen auf
'*****************************************************************************
Tx=""
Tx=Tx & "<input Type=""Text"" Name=""UserName"" VALUE=""%UserName%"" > "
Tx=Tx & "<input Type=""Password"" Name=""UserPwd"" VALUE="""" > "
document.all.NamePwd.innerHTML = Tx
td = "<td style=""hight:25; border:1 solid blue""> "
Tx=""
For i = LBound( LgOn, 2 ) to UBound( LgOn, 2 ) ' für alle Spalten
Tx=Tx & "<table style=""border:1 solid blue; border-collapse:collapse; background-color:#2d3170;"">"
Tx=Tx & "<table style=""border:1 solid blue; border-collapse:collapse; background-color:#2d3170;"">"
Tx=Tx & " <colgroup> <col width=""30"" span=""1""><col width=""320"" span=""2""><col width=""25"" span=""1""></colgroup>"
Tx=Tx & " <tr style=""height:35; border:1 solid blue; font-size:8pt;"">"
Tx=Tx & td & LgOn(0, i ) & "</td>"
Tx=Tx & td & LgOn(1, i ) & "</td>"
If LgOn(3, i ) = "" Then Tx=Tx & td & LgOn(2, i ) & "\" & "%UserName%" & "</td>"
If not LgOn(3, i ) = "" Then Tx=Tx & td & LgOn(2, i ) & "\" & LgOn(3, i ) & "</td>"
Tx=Tx & td & i & "</td>"
Tx=Tx & "</tr></table>"
Next
document.all.NeuListAnzeige.innerHTML = Tx
End Function ' BeimLaden()
'*****************************************************************************
sub LoginStart()
'*****************************************************************************
UserName = Document.All.UserName.Value
If UserName = "" Then Msgbox "Ein Username ist erforderlich" : Exit Sub
UserPwd = Document.All.UserPwd.Value
If UserPwd = "" Then Msgbox "Ein Passwort ist erforderlich" : Exit Sub
Text = ""
For i = LBound( LgOn, 2 ) to UBound( LgOn, 2 ) ' für alle Spalten
Tx=""
If LgOn(3, i ) = "" Then Tx=Tx & LgOn(0, i ) & ", " & LgOn(1, i ) & ", , " & LgOn(2, i ) & "\" & UserName ' & ", " & UserPwd
If not LgOn(3, i ) = "" Then Tx=Tx & LgOn(0, i ) & ", " & LgOn(1, i ) & ", , " & LgOn(2, i ) & "\" & LgOn(3, i ) ' & ", " & UserPwd
Text = Text & "WSHNet.MapNetworkDrive " & Tx & vbCRLF ' : MsgBox Text, 4096, Titel
If LgOn(3, i ) = "" Then WSHNet.MapNetworkDrive LgOn(0, i ) , LgOn(1, i ) , , LgOn(2, i ) & "\" & UserName , UserPwd
If not LgOn(3, i ) = "" Then WSHNet.MapNetworkDrive LgOn(0, i ) , LgOn(1, i ) , , LgOn(2, i ) & "\" & LgOn(3, i ) , UserPwd
' WSHNet.MapNetworkDrive( strLocalName, strRemoteName ,[bUpdateProfile], [strUser] , [strPassword])
Next
Text = "Folgendes wurde erledigt:" & vbCRLF & vbCRLF & Text
MsgBox Text, , Titel
self.close
End Sub ' LoginStart()
</script>
<body onLoad="BeimLaden()" bgcolor="#202060" >
<form>
<center style="font-size:8pt; color:#E0C000; font-family:San-Serif,Verdana;">
<a href="http://dieseyer.de">dieseyer.de</a><br><br>
</center>
<center style="font-size:20pt; color:#E0C000; font-family:San-Serif,Verdana; font-weight:bold;">
Login 2 Server
</center>
<table border="0" cellspacing="20px" width="100%">
<tr>
<td bgcolor=#1d2160 align="center" cellspacing="20%" >
<fieldset><Legend align="Center"></legend>
<BR>
UserName Passwort
<BR><BR>
<span id=NamePwd> </span>
<BR><BR>
<INPUT TYPE="Button" Name="Logon" value="Login starten" onClick="LoginStart()" >
<BR><BR>
</fieldset>
</td>
</tr>
</table>
<center>
<span id=NeuListAnzeige> </span>
</center>
</form>
</body>
</html>
#########################################################################
>>> loginhta.hta <<<
</html>
<head>
<!--
'*** v4.A *** www.dieseyer.de *******************************
'
' Datei: loginhta.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' ermöglicht die Eingabe Benutzer und Passwort, wobei
' das Passworteingabe versteckt (Sternchen) erfolgt.
'
' Im Start-Button ist der Name des zu startende Skripts
' enthalten.
'
' Diese HTA (HTML Application) erstellt auch gleich noch
' das passende (Anmelde- bzw.) Auswerte-Skript.
'
'*********************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
-->
<HTA:APPLICATION ID="oHTA"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
APPLICATIONNAME="Service.CD Anmeldung"
>
<title>Service.CD Anmeldung</title>
<style type="text/css">
TD {font-size:13Pt; color:#E0C000; font-style:bold; font-family:Verdana}
input {font-size:13pt; color:#202060; font-style:bold; font-family:Verdana}
H2 {font-size:24pt; color:#E0C000; font-style:bold; font-family:Verdana}
</style>
</head>
<script language="VBscript">
Const Titel = "loginhta.hta"
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
'****************************************
Sub StartSkript()
'****************************************
UName = Document.All.UserName.Value
If UName = "" Then Msgbox "Ein Username ist erforderlich" : Exit Sub
UPwd = Document.All.UserPwd.Value
If UPwd = "" Then Msgbox "Ein Passwort ist erforderlich" : Exit Sub
VBS = Document.All.StartVBS.Value ' der Button-Text enthält das zu startende Skript
VBS = Replace( VBS, " Starten", "" ) ' ein Teil des Button-Text löschen
VBS = LCase ( VBS ) ' wandeln in Kleinbuchstaben
MsgBox "Uname: " & UName & vbCRLF & "UPwd: " & UPwd, , Titel
' Datei zum Schreiben öffnen (2 => neu anlegen)
Set FileOut = FSO.OpenTextFile( VBS, 2, true )
FileOut.Write "'*** v4.A *** www.dieseyer.de ****************************" & vbCR
FileOut.Write "' File: login.vbs" & vbCR
FileOut.Write "' Autor: dieseyer@gmx.de " & vbCR
FileOut.Write "' dieseyer.de" & vbCR
FileOut.Write "'" & vbCR
FileOut.Write "'*********************************************************" & vbCR
FileOut.Write " " & vbCR
FileOut.Write "Dim oArgs : Set oArgs = Wscript.Arguments " & vbCR
FileOut.Write "'hole alle Argumente " & vbCR
FileOut.Write "'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & vbCR
FileOut.Write "For i = 0 to oArgs.Count - 1 ' hole alle Argumente " & vbCR
FileOut.Write " If i = 0 Then User = oArgs.item(i) " & vbCR
FileOut.Write " If i = 1 Then Pwd = oArgs.item(i) " & vbCR
FileOut.Write "Next " & vbCR
FileOut.Write " " & vbCR
FileOut.Write "MsgBox User & vbCRLF & vbCRLF & Pwd, 4096, WScript.ScriptName" & vbCR
' FileOut.Write "CreateObject(""Wscript.Shell"").Run ""%comspec% /k net use s: \\192.168.101.19\d$ "" & Pwd & "" /user:"" & User" & vbCR
FileOut.Write "CreateObject(""Wscript.Shell"").Run ""net use s: \\192.168.101.19\c$ "" & Pwd & "" /user:"" & User" & vbCR
FileOut.Write "WScript.Sleep 2*1000" & vbCR
' FileOut.Write "CreateObject(""Wscript.Shell"").Run ""S:\dieseyer.de\scr\spielchen.hta""" & vbCR
FileOut.Write "CreateObject(""Scripting.FileSystemObject"").CopyFile ""S:\dieseyer.de\scr\spielchen.hta"", ""R:\""" & vbCR
FileOut.Write "CreateObject(""Wscript.Shell"").Run ""R:\spielchen.hta""" & vbCR
FileOut.Write " " & vbCR
FileOut.Close
Set FileOut = nothing
' WSHShell.Popup VBS & " " & UName & " " & UPwd, 5, , 4096
WSHShell.run VBS & " " & UName & " " & UPwd, 1, False
self.close
End Sub ' StartSkript()
'**************************************************************
Function BeimLaden() ' ruft einige Routinen auf
'**************************************************************
' hier ist nichts implementiert
End Function ' BeimLaden()
</script>
<body onLoad="BeimLaden()" bgcolor="#202060" >
<form>
<BR><BR>
<h2 align="center">Passwortabfrage</h2>
<table border="0" cellspacing="100px" width="100%">
<tr>
<td bgcolor=#1d2160 align="center" cellspacing="70%" >
<fieldset><Legend align="Center"></legend>
<BR>
UserName Passwort
<BR><BR>
<input Type="Text" Name="UserName" Value="PC01\dseyer" >
<input Type="Password" Name="UserPwd" Value="Geheim!" >
<BR><BR>
<INPUT TYPE="Button" Name="StartVBS" value="Login.VBS Starten" onClick="StartSkript()" >
<BR><BR>
</fieldset>
</td>
</tr>
</table>
</form>
</body>
</html>
#########################################################################
>>> loginhta_7s.hta <<<
</html>
<head>
<!--
'*** v10.C *** www.dieseyer.de *****************************
'
' Datei: loginhta_7s.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Wird nicht innerhalb einer bestimmten Zeit das richtige
' Passwort eingegeben, wird der PC herunte gefahren!
'
' Und: Es ist klug, sich vor dem ersten Start das HTA 'etwas'
' anzusehen und die Zeit von 7s zu ändern . . . ;-)
'
'***********************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
-->
<HTA:APPLICATION ID="oHTA"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
APPLICATIONNAME="Service.CD Anmeldung"
>
<title>Login</title>
<style type="text/css">
body {font-size:10pt; color:#E0C000; font-style:bold; font-family:Verdana}
span {font-size:10pt; color:#E0C000; font-style:bold; font-family:Verdana}
TD {font-size:13Pt; color:#E0C000; font-style:bold; font-family:Verdana}
input {font-size:13pt; color:#202060; font-style:bold; font-family:Verdana}
H2 {font-size:24pt; color:#E0C000; font-style:bold; font-family:Verdana}
</style>
</head>
<script language="VBscript">
Const ZeitBisPCAus = 7 ' in Sekunden
Const Passwort = "DasIstGeheim!"
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
Dim PCAus : PCAus = window.setTimeout( "PCShutDown()", ZeitBisPCAus * 1000 ) ' 30*1.000ms
'***********************************************************
Sub StartSkript()
'***********************************************************
UPwd = Document.All.UserPwd.Value
Document.All.UserPwd.Value = ""
If UPwd = "" Then Msgbox "Ein Passwort ist erforderlich!", 4096+vbInformation, document.title : Exit Sub
If not UPwd = Passwort Then Msgbox "Falsches Passwort!", 4096+vbCritical, document.title : Exit Sub
' Passwort war richtig
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.clearTimeout( PCAus )
Self.close
End Sub ' StartSkript()
'***********************************************************
Sub PCShutDown()
'***********************************************************
CreateObject("Wscript.Shell").Run "shutdown.exe -f -s -t 30"
End Sub ' PCShutDown
'***********************************************************
Function BeimLaden() ' ruft einige Routinen auf
'***********************************************************
window.resizeto 400, 270
document.all.ZeigeInfo.innerHTML = "In " & ZeitBisPCAus & "s fährt der PC herunter (Shutdown), wenn nicht das richtige Passwort eingegeben wurde."
End Function ' BeimLaden()
</script>
<body onLoad="BeimLaden()" bgcolor="#202060" >
<form>
<h2 align="center">Passwortabfrage</h2>
<table align="Center" border="0" cellspacing="0px" >
<tr align="Center">
<td bgcolor=#1d2160 align="center" cellspacing="70%" >
<fieldset><Legend align="Center"></legend>
<span style="margin:5px" id="ZeigeInfo" ></span>
<br><br>
<input Type="Password" Name="UserPwd" Value="" >
<br><br>
<INPUT TYPE="Button" Name="StartVBS" value="Login" onClick="StartSkript()" >
<br><br>
</fieldset>
</td>
</tr>
</table>
</form>
</body>
</html>
#########################################################################
>>> lokalegruppen.vbs <<<
'*** v8.1 *** www.dieseyer.de *******************************
'
' Datei: lokalegruppen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "List Local Groups and Their Members"
'
'************************************************************
Option Explicit
Dim strComputer
strComputer = "."
strComputer = "atl-win2k-01"
strComputer = WScript.CreateObject("WScript.Network").ComputerName
MsgBox "Auf """ & strComputer & """ vorhandene lokale Gruppen und deren Mitglieder:" & vbCRLF & LokaleGruppen( strComputer ), , WScript.ScriptName
WScript.Quit
'*** v8.1 *** www.dieseyer.de ****************************
Function LokaleGruppen( PCname )
'*********************************************************
Dim colGroups : Set colGroups = GetObject("WinNT://" & strComputer & "")
Dim objGroup, objUser
Dim i, Txt
colGroups.Filter = Array("group")
For Each objGroup In colGroups
i = i + 1
Txt = Txt & vbCRLF & i & " - " & objGroup.Name
For Each objUser in objGroup.Members
Txt = Txt & vbCRLF & vbTab & objUser.Name
Next
' MsgBox Txt, ,"Gruppe " & i
Next
' MsgBox Txt, , "ENDE"
LokaleGruppen = Txt
End Function ' LokaleGruppen( PCname )
#########################################################################
>>> mac-adr.vbs <<<
'v3.B***************************************************
' File: MAC-Adr.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' !!! Nur WinNT/2k/XP !!!
'
' gibt die MAC-Adr. der Netzwerkkarten aus
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
DIM Ziel, Text1, Text2, FileIn
DIM WSHShell, FSO, WSHNet
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = wshnet.ComputerName & ".tmp"
WshShell.run ("%comspec% /c ipconfig /all > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
Text2 = ""
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text1 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr( UCase ( Text1 ) , "HYSI") then ' diese 4 Zeichen sind im engl. und deut. gleich
Text1 = Replace( Text1, vbCR, "")
Text1 = Replace( Text1, vbLF, "")
Text1 = Mid( Text1 , InStrRev( Text1 , " ") )
Text2 = Text2 & Text1 & vbCRLF
End If
Loop
FileIn.Close
Set FileIn = nothing
'folgende Zeile freigeben
'*******************************************************
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
wshshell.Popup Text2 , 15, WScript.ScriptName
WScript.Quit
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & ".log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (now() & vbTab & LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> mac-adr2.vbs <<<
'v5.1***************************************************
' File: mac-adr2.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Gibt die MAC-Adr. aus.
' Bei mehreren NIC wird die letzte MAC-Adr. ausgegeben,
' die nicht mit "169." beginnt.
'*******************************************************
Option Explicit
MsgBox "=>" & MACadr & "<=" , , WScript.ScriptName
WScript.Quit
'**************************************************************
Function MACadr() ' v4.C - http://dieseyer.de
'**************************************************************
Dim oExec : Set oExec = WScript.CreateObject("WScript.Shell").Exec("%comspec% /c ipconfig /all" )
Dim i
MACadr = ""
Do While Not oExec.StdOut.AtEndOfStream
ReDim Preserve Tst(i) ' Ausgaben in Array umleiten
Tst(i) = oExec.StdOut.ReadLine : i = i + 1
Loop
For i = LBound( Tst ) to UBound( Tst ) - 4
If InStr( Tst( i ) , "Phys" ) > 0 AND InStr( Tst( i ) , " Ad" ) > 0 Then
' 3 Zeilen nach der MAC-Adr. darf die IP-Adr.
If InStr( Tst( i + 3 ) , ": 169.") = 0 Then MACadr = Tst( i ) ' nicht mit 169. beginnen
End If
Next
If not MACadr = "" Then
MACadr = Replace( MACadr, vbCR, "" )
MACadr = Replace( MACadr, vbLF, "" )
MACadr = Mid( MACadr, InStr( MACadr, " : ") )
MACadr = Replace( MACadr, " : ", "" )
End If
End Function ' MACadr() v4.C - http://dieseyer.de
'**************************************************************
#########################################################################
>>> mac-adr3.vbs <<<
'*** v10.1 *** www.dieseyer.de *****************************
'
' Datei: mac-adr3.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Gibt die MAC-Adr. der aktiven Netzwerkkarte(n) zurück.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox WMIMACadr( "." ), , WScript.ScriptName
WScript.Quit
'*** v10.1 *** www.dieseyer.de ******************************
Function WMIMACadr( PC )
'***********************************************************
' Gibt die MAC-Adr. der aktiven Netzwerkkarte(n) zurück.
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & PC & "\root\cimv2")
Dim colItems : Set colItems = objWMIService.ExecQuery ("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
Dim objItem
Dim Tst
For Each objItem in colItems
' wscript.echo objItem.dnshostname & ";" & objItem.IPAddress(0) & ";" & objItem.MACAddress
' Tst = Tst & vbCRLF & objItem.IPAddress(0) & " " & objItem.MACAddress & " ]" & objItem.IPEnabled & "["
' Tst = Tst & vbCRLF & objItem.MACAddress & " ]" & objItem.IPEnabled & "["
' Tst = Tst & vbCRLF & objItem.MACAddress & vbTab & objItem.IPAddress & vbTab & objItem.Description
' Tst = Tst & vbCRLF & objItem.MACAddress & " " & vbTab & objItem.Description & vbTab & objItem.IPAddress(0)
Tst = Tst & vbCRLF & objItem.MACAddress
Next
WMIMACadr = Tst
End Function ' WMIMACadr( PC )
#########################################################################
>>> memberofadgroup.vbs <<<
'*** v8.2 *** www.dieseyer.de *******************************
'
' Datei: MemberOfADGroup.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "List the Active Directory Groups a User Belongs To"
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst
Dim AD
AD = "LDAP://ou=HR,dc=NA,dc=fabrikam,dc=com"
AD = "LDAP://dc=fabrikam,dc=com"
Tst = "pc-dieseyer"
Tst = "LDAP://" & PCimAD( AD, Tst )
MsgBox Tst, , "16 :: "
Tst = MemberOfGroup( Tst )
MsgBox Tst, , "18 :: "
Wscript.Quit
'*** v8.2 *** www.dieseyer.de ****************************
Function MemberOfGroup( PCObjAD )
'*********************************************************
' On Error Resume Next
Dim objUser, intPrimaryGroupID, arrMemberOf, Group
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Set objUser = GetObject ( PCObjAD )
intPrimaryGroupID = objUser.Get( "primaryGroupID" )
arrMemberOf = objUser.GetEx("memberOf")
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
MemberOfGroup = ""
Else
For Each Group in arrMemberOf
MemberOfGroup = Group
Next
End If
' MemberOfGroup = Replace( MemberOfGroup, ",", vbCRLF )
' MsgBox MemberOfGroup, , "45 :: "
End Function ' MemberOfGroup( PCObjAD )
'*** v8.2 *** www.dieseyer.de ****************************
Function PCimAD( AD, PCname )
'*********************************************************
' On Error Resume Next
Const ADS_SCOPE_SUBTREE = 2
Dim objConnection, objCommand, objRecordSet
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = "SELECT distinguishedName FROM '" & AD & "' WHERE objectCategory='Computer' AND Name='" & PCname & "'"
Set objRecordSet = objCommand.Execute
PCimAD = PCname & " ist nicht im AD vorhanden."
On Error Resume Next
PCimAD = objRecordSet.Fields("distinguishedName").Value
On Error GoTo 0
' MsgBox "i = " & i & vbCRLF & "n = " & n & vbCRLF & "Dauer: " & Timer() - StartZeit & vbCRLF & objRecordSet.Fields("distinguishedName").Value , , "76 :: " ' : WScript.Quit
Set objRecordSet = nothing
Set objCommand.ActiveConnection = nothing
Set objCommand = nothing
objConnection.Close
Set objConnection = nothing
End Function ' PCimAD( AD, PCname )
#########################################################################
>>> millisekundentest.vbs <<<
'v5.A*****************************************************
' File: millisekundentest.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' . . . wie die Zeit vergeht . . .
'
'***************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim t, i, s, z
t = "Nr." & vbTab & "akt.Zeit" & vbTab & vbTab & vbTab & "Diff.zu vorh." & vbTab & "Diff.zu Start" & vbCRLF
s = Timer()
z = Timer()
For i = 0 To 11
t = t & i & vbTab & Now() & vbTab & Timer() - z & "s" & vbTab & Timer() - s & "s" & vbCRLF
z = Timer()
WScript.Sleep 1
Next
t = t & vbTab & vbTab & "0,1s sind 100ms . . . nach 10ms?!"
MsgBox t , , "12 :: " & WScript.ScriptName
Function Now()
Now = Date & " " & Time
If InStr( Timer, "," ) > 0 Then Now = Date & " " & Time & Mid( Timer, InStr( Timer, "," ) )
End Function ' Now()
#########################################################################
>>> mp3-bitrate-change.vbs <<<
'v2.4*****************************************************
' File: mp3-bitrate-change.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Wandelt alle mp3-Dateien im aktuellen Ordner in Dateien
' mit einer BitRate von xxx k um.
'
' Dazu am Besten die VBS auf den Desktop (und c:\lame.exe)
' ablegen, den (Windows-) Explorer nicht! im Volbild-Modus
' starten und die Verzeichnisse mit der Maus auf die VBS
' ziehen und fallen lassen . . .
'
' Die Dateinamen der ALTEN Dateien enden mit ".mp3-"
'*********************************************************
Option Explicit
Dim Song, Artist
Dim Text, Text1, Text2, index, Txt(), i1, i2, newpath
Dim fso, fo, fi, FileOut
Dim LameExe, LameParam, ZielVerz, Ziel, Quelle, WSHShell
Dim oArgs, Verz, BitRate, BitRatOrigMin
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
LameExe = "c:\lame.exe"
If not (fso.FileExists(LameExe)) Then
MsgBox """" & UCase(LameExe) & """ nicht vorhanden!", , WScript.ScriptName
WScript.Quit
End If
BitRate = 128
set oArgs = Wscript.Arguments ' hole Argumentsauflistung
If oArgs.Count > 0 Then ' Ja, hole Name
Verz = """" & oArgs.item(0) & """" ' erster Parameter
Verz = oArgs.item(0) ' erster Parameter
Else
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Maus ein Verzeichnis mit mp3-Dateien" & vbCRLF
Text = Text & "auf das Skript ziehen und fallen lassen - JETZT" & vbCRLF
Text = Text & "werden alle gefundenen mp3-Dateien in Dateien " & vbCRLF
Text = Text & "mit " & BitRate & "k BitRate um-en-codiert. Die ALTEN Dateien" & vbCRLF
Text = Text & "enden dann mit "".mp3- . . . """ & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
BitRate = InputBox ("In welche Bitrate sollen die mp3-Dateien" & vbCRLF & vbCRLF & "gewandelt werden?", WScript.ScriptName, BitRate)
If Bitrate = "" then WScript.Quit
i2 = 0
Text = ""
Set fo = fso.GetFolder(Verz)
Set fi = fo.Files ' Datei-Auflistung holen
For Each i1 In fi ' hole Liste aller Dateien
if Ucase(Right(i1.name,4)) = ".MP3" then ' hole nur mp3 - Dateien
Quelle = Verz & "\" & i1.Name & "-"
Ziel = Verz & "\" & i1.Name
if fso.FileExists(Ziel) then ' wenn es eine .mp3- - Datei
if fso.GetFile(Ziel).Size = 0 then ' mit 0 Byte Größe gibt
fso.DeleteFile(Ziel), True ' wird diese gelöscht
WSHShell.Popup "0 Byte große Datei " & Ziel & " wurde gelöscht", 3, WScript.ScriptName
End If
End If
if not fso.FileExists(Quelle) then
Set Text1 = fso.GetFile(Ziel)
Text1.Move Quelle
End If
if not fso.GetFile(Quelle).Size < fso.GetDrive(Left(Quelle,3)).AvailableSpace then
MsgBox "Auf " & Verz & " steht nicht genügend Platz zur Verfügung!", , WScript.ScriptName
WScript.Quit ' wenn weniger als die Größe der Quelle-Datei auf
End If ' dem Ziellaufwerk frei ist - Abbruch
if not FSO.FileExists(Ziel) then ' wenn es noch keine -??????.mp3-Datei gibt
' LameParam = "cmd /k " & LameExe & " -b " & BitRate & " -h --mp3input """ & Quelle & """ """ & Ziel & """"
LameParam = LameExe & " -b " & BitRate & " -h --mp3input """ & Quelle & """ """ & Ziel & """"
WSHShell.Run LameParam , , True
i2 = i2+1
Text = Text & "(" & i2 & ") " & vbTab & "... ~" & Ziel & vbCRLF
End If
End If
Next
Set fo = Nothing ' Datei schließen
If i2 = 0 then Text = "Es wurden keine Dateien zum Wandeln gefunden."
If i2 > 0 then Text = Verz & vbCRLF & vbCRLF & "enthält folgende mp3-Dateien mit " & BitRate & "k-BitRate:" & vbCRLF & vbCRLF & Text
Set FileOut = fso.OpenTextFile(Verz & "\" & WScript.ScriptName & ".log", 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
fileOut.WriteLine (Now() & " " & Text)
fileOut.Close
Set FileOut = Nothing ' Datei schließen
MsgBox Text, , WScript.ScriptName
#########################################################################
>>> mp3-bitrate-change2.vbs <<<
'v5.1*****************************************************
' File: mp3-bitrate-change2.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Wandelt alle mp3-Dateien im aktuellen Ordner und seinen
' Unterordnern in Dateien mit einer BitRate von xxx k um.
'
' Dazu am Besten die VBS auf den Desktop (und c:\lame.exe)
' ablegen, den (Windows-) Explorer nicht! im Volbild-Modus
' starten und die Verzeichnisse mit der Maus auf die VBS
' ziehen und fallen lassen . . .
'
' Die Dateinamen der ALTEN Dateien enden mit ".mp3-"
'*********************************************************
Option Explicit
Dim Song, Artist
Dim Text, Text1, Text2, index, Txt(), i1, i2, newpath
Dim fso, fo, fi, FileOut
Dim LameExe, LameParam, ZielVerz, Ziel, Quelle, WSHShell
Dim oArgs, Verz, BitRate, BitRatOrigMin
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
LameExe = "c:\lame.exe"
LameExe = "F:\audiograbber\lame-3.96\lame.exe"
If not (fso.FileExists(LameExe)) Then
MsgBox """" & UCase(LameExe) & """ nicht vorhanden!", , WScript.ScriptName
WScript.Quit
End If
BitRate = 128
set oArgs = Wscript.Arguments ' hole Argumentsauflistung
If oArgs.Count > 0 Then ' Ja, hole Name
Verz = """" & oArgs.item(0) & """" ' erster Parameter
Verz = oArgs.item(0) ' erster Parameter
Else
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Maus ein Verzeichnis mit mp3-Dateien" & vbCRLF
Text = Text & "auf das Skript ziehen und fallen lassen - JETZT" & vbCRLF
Text = Text & "werden alle gefundenen mp3-Dateien in Dateien " & vbCRLF
Text = Text & "mit " & BitRate & "k BitRate um-en-codiert. Die ALTEN Dateien" & vbCRLF
Text = Text & "enden dann mit "".mp3- . . . """ & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
BitRate = InputBox ("In welche Bitrate sollen die mp3-Dateien" & vbCRLF & vbCRLF & "gewandelt werden?", WScript.ScriptName, BitRate)
If Bitrate = "" then WScript.Quit
i2 = 0
Text = ""
VerzMP3change( Verz )
Dim oFolders : Set oFolders = fso.GetFolder( Verz )
Dim oSubFolder : Set oSubFolder = oFolders.SubFolders
Dim VerzX
For Each VerzX In oSubFolder
VerzMP3change( VerzX.Path )
Next
If i2 = 0 then LogDatei "Es wurden keine Dateien zum Wandeln gefunden."
WSHShell.Run WScript.ScriptName & ".log"
MsgBox "das wars"
WScript.Quit
'*********************************************************
Sub VerzMP3change( Verz )
'*********************************************************
Set fo = fso.GetFolder( Verz )
Set fi = fo.Files ' Datei-Auflistung holen
For Each i1 In fi ' hole Liste aller Dateien
if Ucase(Right(i1.name,4)) = ".MP3" then ' hole nur mp3 - Dateien
Quelle = Verz & "\" & i1.Name & "-"
Ziel = Verz & "\" & i1.Name
if fso.FileExists(Ziel) then ' wenn es eine .mp3- - Datei
if fso.GetFile(Ziel).Size = 0 then ' mit 0 Byte Größe gibt
fso.DeleteFile(Ziel), True ' wird diese gelöscht
WSHShell.Popup "0 Byte große Datei " & Ziel & " wurde gelöscht", 3, WScript.ScriptName
End If
End If
if not fso.FileExists(Quelle) then
Set Text1 = fso.GetFile(Ziel)
Text1.Move Quelle
End If
if not fso.GetFile(Quelle).Size < fso.GetDrive(Left(Quelle,3)).AvailableSpace then
MsgBox "Auf " & Verz & " steht nicht genügend Platz zur Verfügung!", , WScript.ScriptName
WScript.Quit ' wenn weniger als die Größe der Quelle-Datei auf
End If ' dem Ziellaufwerk frei ist - Abbruch
if not FSO.FileExists(Ziel) then ' wenn es noch keine -??????.mp3-Datei gibt
' LameParam = "cmd /k " & LameExe & " -b " & BitRate & " -h --mp3input """ & Quelle & """ """ & Ziel & """"
LameParam = LameExe & " -b " & BitRate & " -h --mp3input """ & Quelle & """ """ & Ziel & """"
LogDatei ( LameParam )
WSHShell.Run LameParam , , True
i2 = i2+1
Text = "(" & i2 & ") " & vbTab & "... ~" & Ziel & vbCRLF
LogDatei ( Text )
End If
End If
Next
Set fi = Nothing
Set fo = Nothing
End Sub ' VerzMP3change( Verz )
'**************************************************************
Sub LogDatei (LogTxt) ' v3.9 - http://dieseyer.de
'**************************************************************
Dim fso, File, FileOut
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' File = fso.GetBaseName( WScript.ScriptName ) & ".log"
File = WScript.ScriptName & ".log"
Set FileOut = fso.OpenTextFile( File , 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogDatei (LogTxt) ' v3.9 - http://dieseyer.de
'**************************************************************
#########################################################################
>>> nachrichtverstecken.hta <<<
<script language="VBScript" type="text/vbscript">
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: nachrichtverstecken.hta
' Autor: mike-winxp@gmx.de
' Auf: www.dieseyer.de
'
'*********************************************************
Dim zzz : zzz=0
Do while zzz<100
on error resume next
window.resizeTo 0,0
window.moveTo -2000,-2000
zzz=zzz+1
Loop
on error goto 0
</script>
<head>
<title>Geheime Nachricht in Datei verstecken</title>
<style type="text/css"> </style>
<HTA:APPLICATION
ID="objTestHTA"
BORDER="thick"
BORDERSTYLE="normal"
CAPTION="yes"
MAXIMIZEBUTTON="no"
MINIMIZEBUTTON="yes"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
SELECTION="no"
SCROLL="no"
SYSMENU="yes"
VERSION="1.1"
WINDOWSTATE="normal"
icon="%systemroot%\system32\migpwd.exe"
>
</head>
<script language="VBscript">
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim MyFiles : Set MyFiles = CreateObject("Scripting.FileSystemObject")
Dim Pfad, gesb, f, BFile
'******************************************************
Sub Window_onLoad
'******************************************************
' window.resizeto Breite, Höhe
window.resizeto 700, 750
' window.moveto Links, Oben
Window.moveTo (Screen.Width-700)/2,(Screen.Height-750)/2
If instr(1,objTestHTA.commandLine,chr(32) & chr(32),1) > 1 Then
MeinArray = Split(objTestHTA.commandLine, chr(32) & chr(32), -1, 1)
Pfad = Replace(MeinArray(1), chr(34), "")
Else
Pfad = ""
End If
if Len(Pfad) > 60 Then
messenge = "... " & Right(Pfad,55)
Else
messenge = Pfad
End if
document.all.Aktueller_File.innerHTML = "Derzeit geöffnete/zu bearbeitende Datei: " & messenge
If Pfad = "" Then Exit Sub
If MyFiles.FileExists(Pfad) = False Then Datfeh = Msgbox ("Die Datei existiert nicht.") : self.close
Set f = MyFiles.GetFile(Pfad)
gesb = Left(Pfad ,Len(Pfad) - len(f.Name))
End Sub
'******************************************************
Sub Verschluesseln()
'******************************************************
lesen = Document.All.Textfeld.Value
If lesen = "" Then Msgbox "Du musst eine Nachricht eingeben, die du verschlüsseln möchtest" : Exit Sub
Code = Document.All.UserPwd.Value
If Code = "" Then Msgbox "Ein Passwort ist erforderlich" : Exit Sub
umftxt = len(lesen)
umfcode = Len(Code)
Do
For t = 1 To umfcode
counter=counter + 1
If counter > umftxt Then Exit Do
c = Asc(Mid(Code, t, 1))
z = Asc(Mid(lesen,counter, 1))
v = c + z + 95 + umfcode + t
w = w & cstr(v)
Next
Loop
If Pfad = "" Then
Document.All.Textfeld.Value = w
Else
Set objDialog = CreateObject("SAFRCFileDlg.FileSave")
objDialog.FileName = "*." & Right(Pfad,len(Pfad) - Instrrev(Pfad, ".",-1,1))
objDialog.FileType = "Alle Dateien"
intReturn = objDialog.OpenFileSaveDlg
If intReturn Then
Set schreiben = MyFiles.CreateTextFile(objDialog.FileName & ".temp")
schreiben.Write "*****######*****" & w
schreiben.close
w = ""
Else
Exit Sub
End If
Return = WshShell.Run("cmd /c copy /B " & chr(34) & Pfad & chr(34) & " + " & chr(34) & objDialog.FileName & ".temp" & chr(34) & " " & chr(34) & objDialog.FileName & chr(34), 0, True)
MyFiles.DeleteFile(objDialog.FileName & ".temp")
Document.All.Textfeld.Value = w
End If
document.all.Aktueller_File.innerHTML = "Derzeit geöffnete/zu bearbeitende Datei: " : Pfad = ""
End Sub
'******************************************************
Sub Entschluesseln()
'******************************************************
On Error Resume next
Code = Document.All.UserPwd.Value
If Code = "" Then Msgbox "Ein Passwort ist erforderlich" : Exit Sub
umfcode = Len(Code)
If Pfad = "" Then
lesen = Document.All.Textfeld.Value
if lesen = "" Then If lesen = "" Then Msgbox "Du musst eine Nachricht eingeben oder importieren, die du entschlüsseln möchtest" : Exit Sub
Else
Set file = MyFiles.OpenTextFile(Pfad,1,True)
var = file.readall
file.Close
If Instrrev(var, "*****######*****",-1,1) < 1 Then
Msgbox "Datei enthält keine Nachricht. Möglicherweiße ist die Datei beschädigt."
Exit Sub
End If
lesen = Mid(var, Instrrev(var, "*****######*****",-1,1) + 16,len(var))
End if
umftxt = len(lesen)
counter = 1
Do
For t = 1 To umfcode
c = Asc(Mid(Code, t, 1))
z = Mid(lesen, counter, 3)
v = eval(z) - c - 95 - umfcode - t
w = w & chr(v)
counter=counter + 3
If counter > umftxt Then Exit Do
Next
Loop
Document.All.Textfeld.Value = w
document.all.Aktueller_File.innerHTML = "Derzeit geöffnete/zu bearbeitende Datei: " : Pfad = ""
End sub
'******************************************************
Sub Text_speichern()
'******************************************************
Set objDialog = CreateObject("SAFRCFileDlg.FileSave")
objDialog.FileName = "Document1.txt"
objDialog.FileType = "Text Document"
intReturn = objDialog.OpenFileSaveDlg
If intReturn Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(objDialog.FileName)
objFile.WriteLine Document.All.Textfeld.Value
objFile.Close
Else
Exit Sub
End If
End Sub
'******************************************************
Sub Text_importieren()
'******************************************************
call BFF() : Datei = BFile
If Datei = "" then exit sub
if MyFiles.FileExists(Datei) = FALSE then Datfeh = Msgbox ("Die Datei existiert nicht.") : Exit Sub
Set txt = MyFiles.OpenTextFile(Datei, 1)
Document.All.Textfeld.Value = txt.readall
txt.close
End Sub
'******************************************************
Function BFF()
'******************************************************
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
BFile = Dialog.FileName
End Function
'******************************************************
Sub Datei_waelen()
'******************************************************
call BFF() : Pfad = BFile
if Pfad = "" Then document.all.Aktueller_File.innerHTML = "Derzeit geöffnete/zu bearbeitende Datei: " : exit Sub
Set f = MyFiles.GetFile(Pfad)
gesb = Left(Pfad ,Len(Pfad) - len(f.Name))
if Len(Pfad) > 60 Then
messenge = "... " & Right(Pfad,55)
Else
messenge = Pfad
End if
document.all.Aktueller_File.innerHTML = "Derzeit geöffnete/zu bearbeitende Datei: <font color='#FF0000'>" & messenge & "</font>"
End Sub
'******************************************************
Sub Hilfe()
'******************************************************
BtnCode = WshShell.Popup( chr(169) &" mike-winxp@gmx.de" & vbcr &_
"Version 1.1" & vbcr &vbcr &_
"Zweck und Funktion des Programms:" & vbcr &_
"Nachrichten/Textdateien in anderen Dateien zu verstecken. Hierbei wird die Nachricht zunächst mit" & vbcr &_
"einem beliebigen Passwort verschlüsselt (einfacher Algorithmus für niedrige Sicherheitsansprüche)" & vbcr &_
"und anschließend an eine Datei gehängt. Die Tarnung ist perfekt." & vbcr &_
"Wenn dann noch der Name der Datei mit Nachricht geändert wird, ist es für einen Außenstehenden" & vbcr &_
"fast unmöglich festzustellen 1. in welcher Datei sich eine Nachricht befindet, 2. Was in der Nachricht steht." & vbcr &_
"Gehen Sie hierzu auf 'Datei öffnen' um eine Datei auszuwählen, in der die Nachricht versteckt werden soll." & vbcr &_
"Anschließend geben Sie eine Nachricht in das Textfeld ein, oder importieren einen bereits fertigen Text." & vbcr &_
"Nach der Eingabe eines Passworts (je länger dieses ist desto besser ist die Verschlüsselung) erstellen" & vbcr &_
"Sie durch einen klick auf 'Nachricht verschlüsseln' eine neue Datei, die aussieht wie die Originaldatei," & vbcr &_
"jedoch die von Ihnen eingegebene Botschaft (in verschlüsselter Form) enthält." & vbcr & vbcr &_
"Des weiteren können Sie Nachrichten verschlüsseln, ohne sie anschließend in eine andere Datei " & vbcr &_
"zu packen. Dies macht vor allem bei vertraulichen Emailnachrichten Sinn." & vbcr &_
"Geben Sie hierzu eine Nachricht in das Textfeld ein, oder importieren einen bereits fertigen Text. " & vbcr &_
"Geben Sie ein beliebiges Passwort ein und klicken Sie anschließend auf 'Nachricht verschlüsseln'." & vbcr & vbcr &_
"Um aus einer Datei eine verschlüsselte Botschaft auszulesen, gehen Sie auf 'Datei öffnen' und " & vbcr &_
"wählen die Datei aus, die die Nachricht enthält." & vbcr &_
"Nun geben sie das Passwort ein klicken auf 'Nachricht entschlüsseln'" & vbcr & vbcr &_
"Um eine Nachricht aus einem Textdokument zu entschlüsseln. Klicken sie auf 'Text importieren'." & vbcr &_
"Dann geben sie das Passwort ein und klicken 'Nachricht entschlüsseln'" & vbcr & vbcr &_
"Rechtliches:" & vbcr &_
"Mit der Benutzung dieses Programms erklären Sie sich einverstanden, dass der Autor nicht die fehlerfreie "& vbcr &_
"Funktion dieses Programms garantiert und keine Haftung für Schäden aller Art übernimmt, die durch dieses " & vbcr &_
"Programm an Hardware und Software des Benutzers entstanden sind.",1000,"Hilfe",0)
End sub
</script>
<body bgcolor="#FF9900">
<div id=Aktueller_File style="width: 664; height: 19" title="Diese Datei ist gerade geöffet. Sie können eine Nachricht in dieser Datei verstecken, oder eine versteckte Nachricht entschlüsseln."> </div>
<p> <font size="2"><input type="button" value="Datei öffnen" name="B8" onclick="Datei_waelen()" title="Wählen sie eine Datei, in der sie eine Nachricht verstecken wollen/oder in der eine Nachricht versteckt ist." style="color: #460000; background-color: #FCF5C7; border-style: ridge; border-color: #CC3300">
Öffnen Sie eine Datei, um eine verschlüsselte Nachricht darin zu
verstecken </font>
</p>
<p><font size="2">----------------------------------------------------------------------------------------------------------------------------------------------------------------------</font>
</p>
<p><font size="3">Passwort:</font> <input Type="Password" Name="UserPwd" Value="" size="35" title="Geben sie hier das Passwort ein, mit dem Sie die Nachricht verschlüsseln wollen, oder mit dem die Datei verschlüsselt ist." style="background-color: #FCF5C7; border-style: inset; border-color: #CC3300" >
<font size="2"> <input type="button" value="Text importieren" name="B7" onclick="Text_importieren()" title="Wenn sie eine Nachricht als .txt Datei gespeichert haben, können Sie diese importieren." style="background-color: #FCF5C7; border-style: ridge; border-color: #6F1C00">
</font>
</p>
<p><font size="2" face="Arial" title="Tragen Sie hier die Nachricht ein, die Sie verschlüsseln wollen. Sie haben auch die Möglichkeit einen Text zu importieren. Falls ein entschlüsselter Text nur teilweise oder gar nicht leserlich ist, haben Sie ein falsches Passwort verwendet." ><u>Nachricht:</u></font>
</p>
<p><textarea rows="25" id="Textfeld" name="Textfeld" cols="108" style="font-family: Arial; position: relative; background-color: #FCF5C7; border-style: inset; border-color: #CC3300"></textarea>
</p>
<p><input type="button" value="Nachricht entschlüsseln" name="B5" onclick="Entschluesseln()" title="Wenn sie eine Datei geöffnet haben, wird versucht aus dieser eine Nachricht zu entschlüsseln. Wenn Sie keine Datei geöffnet haben, wird die Nachricht, die Sie ins Nachrichtenfeld eingetragen haben, entschlüsselt." style="background-color: #FCF5C7; border-style: ridge; border-color: #6F1C00" >
<input type="button" value="Nachricht verschlüsseln" name="B3" onclick="Verschluesseln" title="Wenn sie eine Datei geöffnet haben, wird ihre Nachricht verschlüsselt in einer Kopie dieser Datei gespeichert. Wenn Sie keine Datei geöffnet haben, wird die Nachricht, die Sie ins Nachrichtenfeld eingetragen haben, nur verschlüsselt." style="background-color: #FCF5C7; border-style: ridge; border-color: #6F1C00" >
<input type="button" value="Nachricht speichern" name="B5" onclick="Text_speichern()" title="Speichert den aktuellen Text." style="background-color: #FCF5C7; border-style: ridge; border-color: #6F1C00">
</p>
<p><input type="button" value="Hilfe" name="B3" onclick="Hilfe()" style="background-color: #FCF5C7; border-style: ridge; border-color: #6F1C00"></p>
</body>
#########################################################################
>>> netzlaufwerkedetails.vbs <<<
'v2.5*****************************************************
' File: NetzLaufWerkeDetails.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' zeigt Netzlaufwerk mit zugeordnetem Laufwerksbuchstaben
'*********************************************************
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNetzWerk = WScript.CreateObject("WScript.NetWork")
Set WSHLaufWerk = WSHNetzWerk.EnumNetworkDrives()
TextX = "Liste der Netzwerlaufwerke:" & vbCRLF
For i = 0 To WSHLaufWerk.Count -1 Step 2
TextX = TextX & vbCRLF ' neue Zeile
TextX = TextX & i & vbTab
if WSHLaufWerk.Item(i) <> "" Then
TextX = TextX & WSHLaufWerk.Item(i) & vbTab
TextX = TextX & fso.getDrive(WSHLaufWerk.Item(i)).ShareName
End If
Next
MsgBox TextX, , WScript.ScriptName
#########################################################################
>>> netzpfadermitteln.vbs <<<
'*** v11.4 *** www.dieseyer.de *****************************
'
' Datei: netzpfadermitteln.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Enthält zwei Prozeduren:
'
' NetzPfadVonLwErmitteln()
' erwartet einen Laufwerksbuchstaben als Parameter
' NetzPfadVonLwErmitteln() wird verwendet in:
' kontext-pfadinzwischenablage.vbs
'
' NetzPfadErmitteln()
' erwartet einen Laufwerksbuchstaben oder einen Pfad
' zu einer Datei oder einem Verzeichnis als Parameter
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim xxx
xxx = "C:"
MsgBox "NetzPfadVonLwErmitteln( """ & xxx & """ )" & vbCRLF & vbCRLF & vbTab & "ergibt:" & vbCRLF & vbCRLF & NetzPfadErmitteln( xxx ), , "026 :: " & Wscript.ScriptName
xxx = "K:"
MsgBox "NetzPfadVonLwErmitteln( """ & xxx & """ )" & vbCRLF & vbCRLF & vbTab & "ergibt:" & vbCRLF & vbCRLF & NetzPfadErmitteln( xxx ), , "029 :: " & Wscript.ScriptName
' WScript.Quit
xxx = "C:"
MsgBox "NetzPfadErmitteln( """ & xxx & """ )" & vbCRLF & vbCRLF & vbTab & "ergibt:" & vbCRLF & vbCRLF & NetzPfadErmitteln( xxx ), , "034 :: " & Wscript.ScriptName
xxx = "K:\iRadio Lounge\brother of soul - be right there.mp3"
MsgBox "NetzPfadErmitteln( """ & xxx & """ )" & vbCRLF & vbCRLF & vbTab & "ergibt:" & vbCRLF & vbCRLF & NetzPfadErmitteln( xxx ), , "037 :: " & Wscript.ScriptName
xxx = "v:\123\meine.txt"
MsgBox "NetzPfadErmitteln( """ & xxx & """ )" & vbCRLF & vbCRLF & vbTab & "ergibt:" & vbCRLF & vbCRLF & NetzPfadErmitteln( xxx ), , "040 :: " & Wscript.ScriptName
' WScript.Quit
xxx = "http://dieseyer.de"
MsgBox "NetzPfadErmitteln( """ & xxx & """ )" & vbCRLF & vbCRLF & vbTab & "ergibt:" & vbCRLF & vbCRLF & NetzPfadErmitteln( xxx ), , "045 :: " & Wscript.ScriptName
xxx = "\\dieseyer\de"
MsgBox "NetzPfadErmitteln( """ & xxx & """ )" & vbCRLF & vbCRLF & vbTab & "ergibt:" & vbCRLF & vbCRLF & NetzPfadErmitteln( xxx ), , "048 :: " & Wscript.ScriptName
WScript.Quit
'*** v11.4 *** www.dieseyer.de *****************************
Function NetzPfadErmitteln( Pfad )
'***********************************************************
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oDrives : Set oDrives = WSHNet.EnumNetworkDrives
Dim Lw, Verz, Tst, n
' ist übergebener Pfad bereits Netzwerkpfad?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Left( Pfad, 2 ) = "\\" Then NetzPfadErmitteln = Pfad : Exit Function
' ist übergebener Pfad verbundenes Laufwerk?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not Mid( Pfad, 2, 1 ) = ":" Then NetzPfadErmitteln = Pfad : Exit Function
' MsgBox "Function NetzPfadErmitteln( " & Pfad & " )", , "071 :: "
Lw = Left( UCase( Pfad ), 1 ) ' nur der Laufwerksbuchstabe
Pfad = Mid( Pfad, 3 ) ' alles nach dem Dioppelpunkt des Laufwerksbuchstaben
' MsgBox Lw & vbCRLF & vbCRLF & Pfad, , "075 :: "
On Error Resume Next
Tst = fso.GetDrive( Lw ).DriveType
' On Error Resume Next
Tst = Int( Tst )
' lokale Festplatte: 2 = fso.GetDrive( Pfad ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If 2 = Tst Then
Tst = "\\" & WSHNet.ComputerName & "\" & Lw & "$"
' MsgBox Tst, , "086 :: "
If fso.FolderExists( Tst ) Then NetzPfadErmitteln = Tst : Exit Function
End If
' verbundenes Netzlaufwerk: 3 = fso.GetDrive( Pfad ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Int( 3 ) = Int( Tst ) Then
For n = 0 to oDrives.Count - 1 Step 2
If InStr( oDrives.Item( n ), Lw ) = 1 Then
NetzPfadErmitteln = oDrives.Item( n + 1 ) & Pfad
' MsgBox oDrives.Item( n ) & vbCRLF & vbCRLF & oDrives.Item( n + 1 ) & vbCRLF & Pfad, , "096 :: " & Tst
Exit Function
End If
Next
End If
End Function ' NetzPfadErmitteln( Pfad )
'*** v11.4 *** www.dieseyer.de *****************************
Function NetzPfadVonLwErmitteln( Lw )
'***********************************************************
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oDrives : Set oDrives = WSHNet.EnumNetworkDrives
Dim Tst, n
' ist übergebenes Lw ein Pfad?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Lw ) > 2 Then MsgBox Lw & vbCRLF & vbCRLF & Lw, , "115 :: "
If Len( Lw ) > 2 Then NetzPfadVonLwErmitteln = Lw : Exit Function
' ist zweites Zeichen kein Doppelpunkt?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( Lw ) = 2 Then If not ":" = Mid( Lw, 2 ) Then MsgBox Lw & vbCRLF & vbCRLF & Lw, , "120 :: "
If Len( Lw ) = 2 Then If not ":" = Mid( Lw, 2 ) Then NetzPfadVonLwErmitteln = Lw : Exit Function
' MsgBox "Function NetzPfadVonLwErmitteln( " & Lw & " )", , "123 :: "
Lw = Left( UCase( Lw ), 1 ) ' nur der Laufwerksbuchstabe
' MsgBox Lw & vbCRLF & vbCRLF & Lw, , "126 :: "
On Error Resume Next
Tst = fso.GetDrive( Lw ).DriveType
' On Error Resume Next
Tst = Int( Tst )
' lokale Festplatte: 2 = fso.GetDrive( Lw ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If 2 = Tst Then
Tst = "\\" & WSHNet.ComputerName & "\" & Lw & "$"
' MsgBox Tst, , "137 :: "
If fso.FolderExists( Tst ) Then NetzPfadVonLwErmitteln = Tst : Exit Function
End If
' verbundenes Netzlaufwerk: 3 = fso.GetDrive( Lw ).DriveType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Int( 3 ) = Int( Tst ) Then
For n = 0 to oDrives.Count - 1 Step 2
If InStr( oDrives.Item( n ), Lw ) = 1 Then
NetzPfadVonLwErmitteln = oDrives.Item( n + 1 )
' MsgBox oDrives.Item( n ) & vbCRLF & vbCRLF & oDrives.Item( n + 1 ) & vbCRLF & Lw, , "147 :: " & Tst
Exit Function
End If
Next
End If
End Function ' NetzPfadVonLwErmitteln( Lw )
#########################################################################
>>> netzverb-zu-server.vbs <<<
'v2.6*****************************************************
' File: netzverb-zu-server.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Netzlaufwerk verbinden mit einem anderen UserName, als
' der, der am System (Domain) gerade angemeldet ist.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
DIM WSHShell, WSHNetzWerk, WSHLaufWerk, FSO, AllDrives
DIM Titel, Fehler, FehlerNr
DIM LogonName, LogonPwd, Server, ServerIP, ServerDomain
DIM FileIn, FileOut
DIM TmpTxt, TextX, i, LW, FGN, IPadr, EndIPadr
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHNetzWerk = WScript.CreateObject("WScript.NetWork")
Set WSHLaufWerk = WSHNetzWerk.EnumNetworkDrives()
Set FSO = CreateObject("Scripting.FileSystemObject")
ServerDomain = "ALLIANZ\SERVER-"
LogonName = "Maier"
LogonName = WSHNetzWerk.UserName
TmpTxt = "~tmp~.tmp"
Titel = WScript.ScriptName
Server = "ServerXYZ" ' Ziel-Server
LW = "W:" ' LaufWerksBuchstaben, die verwendet werden sollen
FGN = "C$" ' FreiGabeName auf dem Ziel-Server
FGN = "IPC$" ' FreiGabeName auf dem Ziel-Server
FGN = "d$" ' FreiGabeName auf dem Ziel-Server
LogDatei vbCRLF & now() ' LogDatei SUB-Aufruf
' Server erfragen
' ~~~~~~~~~~~~~~~
TextX = "An welchen Server wollen Sie sich an anmelden?"
Server = InputBox (TextX, Titel, Server)
Server = UCase(Server)
If Server = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
ServerIP = ""
ServerTesten ' ServerTesten SUB-Aufrufen
' ~~~~~~~~~~~~~~~ ' ermittelt IPadr. aus DNS-Name
' Die Verbindung von Netzlaufwerken klappt m.E. per IP-Adresse besser bzw. fast immer
If ServerIP = "" Then
TextX = Server & vbCRLF & vbCRLF & "ist nicht per PING erreichbar!"
LogDatei TextX
MsgBox TextX, , Titel
WScript.Quit
End If
' FGN erfragen
' ~~~~~~~~~~~~
TextX = "Welcher Freigabenamen auf " & vbCRLF & vbCRLF & """ \\" & UCase(Server) & "\ "" soll verwendet werden?"
FGN = InputBox (TextX, Titel, FGN)
If FGN = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
' LW erfragen
' ~~~~~~~~~~~
LW = ""
If not UCase(FGN) = "IPC$" then
TextX = "Welchen Laufwerksbuchstaben soll die Verbindung zu " & vbCRLF & vbCRLF & """ \\" & UCase(Server) & "\" & FGN & """ verwenden?"
TextX = TextX & vbCRLF & vbCRLF & "( "
For i = 0 To WSHLaufWerk.Count -1 Step 2
if WSHLaufWerk.Item(i) <> "" Then
TextX = TextX & WSHLaufWerk.Item(i) & " "
End If
Next
TextX = TextX & vbCRLF & "werden bereits verwendet.) " & vbCRLF
LW = "W:"
LW = InputBox (TextX, Titel, LW)
If LW = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
End If
' LogonName erfragen
' ~~~~~~~~~~~~~~~~~~
TextX = "Das Ganze funktioniert nur, wenn die Passwörter synchron sind!" & vbCRLF & vbCRLF
TextX = TextX & "Mit welchem Namen wollen Sie sich an " & Server & " bzw. " & ServerIP & " anmelden?"
' Domäne\UserName
LogonName = InputBox (TextX, Titel, ServerDomain & LogonName)
LogonName = UCase(LogonName)
If LogonName = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, Titel, 64
WScript.Quit
End If
' Trennen
' ~~~~~~~
LWtrennen FGN ' LWtrennen SUB-Aufruf
' Verbinden
' ~~~~~~~~~
LWverbinden LW, FGN ' LWverbinden SUB-Aufruf
WSHShell.Popup (". . . erledigt!"), 3, Titel, 64
WScript.Quit
'*********************************
Function LWtrennen(LW)
'*********************************
if FSO.DriveExists(LW) then ' LaufWerk vorhanden?
if FSO.GetDrive(LW).DriveType = 3 then ' ist es NetzLaufWerk?
For i = 2 To WSHLaufWerk.Count -1 Step 2
If WSHLaufWerk.Item(i) = LW Then TextX = fso.getDrive(WSHLaufWerk.Item(i)).ShareName
Next
TextX = LW & " ist mit " & TextX & " verbunden " & vbCRLF & vbCRLF
TextX = TextX & "und wird jetzt getrennt - stimmt's ? "
i = MsgBox(TextX, 4+32+256, Titel)
if i = 6 then WSHNetzWerk.RemoveNetWorkDrive LW ' NetzLaufWerk trennen
End If
End If
End Function ' LWtrennen(LW)
'*********************************
Function LWverbinden(LW, FGN)
'*********************************
On Error Resume Next ' fals es nicht klappt
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.RemoveNetworkDrive "\\" & ServerIP, true '
FehlerNr = Err.Number
Fehler = Err.Description
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & ServerIP
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.RemoveNetworkDrive \\" & ServerIP
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.RemoveNetworkDrive "\\" & Server, true '
FehlerNr = Err.Number
Fehler = Err.Description
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & Server
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.RemoveNetworkDrive \\" & Server
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.MapNetWorkDrive LW, "\\" & Server & "\" & FGN, , LogonName
FehlerNr = Err.Number
Fehler = Err.Description
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & Server & "\" & FGN
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.MapNetWorkDrive LW, \\" & Server & "\" & FGN & " " & LogonName
If FehlerNr = 13 then
WSHShell.Popup "Verbinden mit " & "\\" & Server & "\" & FGN & " war erfolgreich (UserName: " & LogonName & ")", 3, Titel, 64
End If
If not FehlerNr = 13 then
WSHShell.Popup Fehler & vbCRLF & ". . . beim Verbinden mit " & "\\" & Server & "\" & FGN & " (UserName: " & LogonName & ")" & vbCRLF & vbCRLF & "Es wird jetzt über IP versucht!", 3, Titel, 64
Err.Number = ""
Err.Description = ""
Fehler = Err.Description
FehlerNr = Err.Number
WSHNetzWerk.MapNetWorkDrive LW, "\\" & ServerIP & "\" & FGN, , LogonName
Fehler = Err.Description
FehlerNr = Err.Number
' MsgBox FehlerNr & vbTab & Fehler & vbTab & "\\" & ServerIP & "\" & FGN
LogDatei ":" & FehlerNr & vbTab & Fehler & vbCRLF & vbTab & vbTab & "nach WSHNetzWerk.MapNetWorkDrive LW, \\" & ServerIP & "\" & FGN & " " & LogonName
End If
On Error GoTo 0
If not FehlerNr = 13 then
WSHShell.Popup Fehler & vbCRLF & ". . . beim Verbinden mit " & "\\" & ServerIP & "\" & FGN & " (UserName: " & LogonName & ")" , , WScript.ScriptName
End If
If FehlerNr = 13 then
WSHShell.Popup "Verbinden mit " & "\\" & ServerIP & "\" & FGN & " war erfolgreich (UserName: " & LogonName & ")", 3, Titel, 64
End If
' If not Fehler = "" then MsgBox Fehler & vbCRLF & ". . . beim Verbinden mit " & FGN & " (UserName: " & LogonName & ")", , WScript.ScriptName
' If Fehler = "" then WSHShell.Popup ("Verbinden mit " & FGN & " war erfolgreich (UserName: " & LogonName & ")"), 3, Titel, 64
End Function ' LWverbinden
'*********************************
Sub ServerTesten
'*********************************
if fso.FileExists(TmpTxt) Then fso.DeleteFile(TmpTxt), True ' Datei löschen
if fso.FileExists(TmpTxt) Then wshshell.Popup "Bitte nicht OK drücken!!!" , 3, " Nach 3sek bin ich weg!", vbExclamation
if fso.FileExists(TmpTxt) Then MsgBox TmpTxt & " konnte nicht gelöscht werden - ABBRUCH", , Titel
if fso.FileExists(TmpTxt) Then WScript.Quit
WSHShell.run ("%comspec% /c Ping " & Server & " -n 1 -w 500 > " & TmpTxt), 0, True ' Ping nur einmal ausführen
Set FileIn = fso.OpenTextFile(TmpTxt, 1 ) ' Datei zum Lesen öffnen
TextX = FileIn.ReadAll ' alles lesen
FileIn.Close
Set FileIn = nothing
if fso.FileExists(TmpTxt) Then fso.DeleteFile(TmpTxt), True ' Datei löschen
TextX = Split(TextX, vbCRLF) ' alles gelesene in Zeilen aufteilen
for i = 0 to ubound(TextX) ' jede Zeile überprüfen
If InStr(UCase(TextX(i)), "TTL=") Then ' ob TTL= enthalten ist, wenn ja (PING war erfolgreich)
' Bei der Ping-Ausgabe befindet sich hinter der IP-Adresse ein ":" - was links vom ":" steht, ist interessant
ServerIP = Mid(TextX(i), 1, InStr(UCase(TextX(i)), ":") -1 )
' Bei der Ping-Ausgabe befindet sich vor der IP-Adresse ein " " - was rechst vom " " steht, ist die IP-Adr.
ServerIP = Mid(ServerIP, InStrRev(ServerIP, " ") +1 )
End If
next
End Sub ' ServerTesten
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".log", 8, true)
FileOut.WriteLine (LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> now.vbs <<<
'v6.1*****************************************************
' File: now.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Überschreibt die now-Function und gibt dann die Zeit
' mit grösserer Genauigkeit zurück: 10.10.2005 17:10:22.13
'
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ! ! ! Damit funktioniert natürlich DateDiff nicht mehr ! ! !
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'
'***************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox "Jetzt ist es : " & Now() , , "17:: " & WScript.ScriptName
'*******************************************************
Function Now() ' 6.1 - http://dieseyer.de
'*******************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ! ! ! Damit funktioniert natürlich DateDiff nicht mehr ! ! !
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Now gibt jetzt einen String und kein (verwendbares) Datum zurück
Now = Date & " " & Time & ",00"
' Wenn Timer() ein Komma enthält, wird: Now = Date & " " & Time & [Rest von Timer]
If InStr( Timer(), "," ) > 0 Then Now = Date & " " & Time & Mid( Timer(), InStr( Timer(), "," ) )
' Wenn Timer() nach dem Komma einstellig ist, wir eine 0 angehangen
If Len( Mid( Now, InStrRev( Now, "," ) ) ) = 2 Then Now = Now & "0"
End Function ' Now() ' 6.1 - http://dieseyer.de
#########################################################################
>>> offenedateien.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
'
' Datei: offenedateien.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt
Dim DateiDienst 'IADsFileService
Dim GeoeffenteRessource 'IADsResource
Dim PC
PC = "."
Set DateiDienst = GetObject("WinNT://" & PC & "/lanmanserver,fileservice")
Txt = ""
For Each GeoeffenteRessource In DateiDienst.Resources
Txt = Txt & vbCRLF & vbCRLF & GeoeffenteRessource.Path & vbTab & GeoeffenteRessource.User & vbTab & GeoeffenteRessource.LockCount
Next
MsgBox Txt, , "26 :: " & WScript.Quit
#########################################################################
>>> ordner-leeren.vbs <<<
'v5.1*****************************************************
' File: Ordner-Leeren.vbs
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' Leert einen Ordner, in dem die enthaltenen Dateien in
' einen anderen Ordner kopiert werden. Gibt es dort bereits
' Dateien mit gleichen Namen, wird eine dreistellige Zahl
' vor der Dateiendung eingefügt.
' Unterordner werden nicht abgearbeitet.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Const QuellVerz = "c:\test1\" ' unbedingt mit \ am Ende
Const ZielVerz = "c:\test2\" ' unbedingt mit \ am Ende
' Zielverzeichnis anlegen, wenn nicht vorhanden
if not fso.FolderExists( ZielVerz ) then fso.CreateFolder ( ZielVerz )
' Wenn es das Quellverzeichnis nicht gibt, macht das Skript keinen Sinn - Quit
if not fso.FolderExists( QuellVerz ) then
MsgBox UCase( QuellVerz ) & " existiert nicht!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", , WScript.ScriptName
WScript.Quit
End If
Do
DateiCheck QuellVerz, ZielVerz ' Sub - Aufruf
If not fso.FileExists( WScript.ScriptName ) Then Exit Do ' sobald es das Skript nicht mehr gibt
WScript.Sleep 1000*10 ' 10s warten
Loop
MsgBox "Das ist das Ende . . . ", , WScript.ScriptName
WScript.Quit
' *********************************************************
Sub DateiCheck( QuellVerz, ZielVerz ) ' Anfang
' *********************************************************
' Dim oFiles, Folder, oFolders, QuellDatei, ZielDatei
' Dim i, n, Text, Pfad, DateiX
Dim i, n
Dim oFolders, oFiles, DateiX
Dim QuellDatei, ZielDatei
Set oFolders = fso.GetFolder( QuellVerz )
Set oFiles = oFolders.Files
For Each DateiX In oFiles ' jede Datei im Ordner
QuellDatei = QuellVerz & DateiX.Name ' Datei mit komplettem Pfad
If not fso.FileExists( ZielVerz & DateiX.Name ) Then ' gibt es diese Datei im ZielVerz. nicht
On Error Resume Next ' verhindert den Skriptabbruch bei Fehler
fso.MoveFile QuellDatei, ZielVerz & DateiX.Name ' Datei ins ZielVerz. verschieben
On Error GoTo 0
Else
i = 0 ' Dateinummer
Do
n = i
If Len( n ) = 1 Then n = "0" & n ' auf zweistellig erweitern
If Len( n ) = 2 Then n = "0" & n ' auf dreistellig erweitern
n = "_" & n & "." ' erweitern um Untersrtich und Punkt
ZielDatei = ZielVerz & fso.GetBaseName( QuellDatei ) & n & fso.GetExtensionName( QuellDatei )
If not fso.FileExists( ZielDatei ) Then
On Error Resume Next ' verhindert den Skriptabbruch bei Fehler
fso.MoveFile QuellDatei, ZielDatei
On Error GoTo 0
Exit Do
End If
i = i + 1 ' Dateinummer wird hochgezählt
Loop
End If
Next
Set oFiles = nothing
Set oFolders = nothing
End Sub ' DateiCheck()
#########################################################################
>>> ordnerauswahl.vbs <<<
'v3.9*****************************************************
' File: OrdnerAuswahl.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Nach einem Beitrag von Th. Gudera in der MS-NG
'*********************************************************
dialog = BrowseForFolder("Wählen Sie das Verzeichnis",&h1, 0)
msgbox dialog, , WScript.ScriptName
' *********************************************************
Function BrowseForFolder(strPrompt, BrowseInfo, root) ' Start
' *********************************************************
Dim objShell, objFolder, intColonPos, objWshShell
Set objWshShell = CreateObject("WScript.Shell")
' In der Folgezeile gibt's eine Fehlermeldung, wenn
' die Shell32.dll nicht v4.71 oder höher ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&h0&, strPrompt, BrowseInfo, root)
' On Error Resume Next
BrowseForFolder = objFolder.ParentFolder.ParseName(objFolder.Title).Path
If Err.Number <> 0 Then
BrowseForFolder = Null
If objFolder.Title = "Desktop" Then
BrowseForFolder = objwshshell.SpecialFolders("Desktop")
End If
intColonPos = InStr(objFolder.Title, ":")
If intColonPos > 0 Then
BrowseForFolder = Mid(objFolder.Title, intColonPos - 1, 2) & "\"
End If
End If
Set objShell = nothing
Set objWshShell = nothing
Set objFolder = nothing
End Function ' BrowseForFolder(strPrompt, BrowseInfo, root)
' *********************************************************
#########################################################################
>>> ordnervergleich.vbs <<<
'*** v9.3 *** www.dieseyer.de *******************************
' File: Ordnervergleich.vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Zwei ausgesuchte Ordner in ihrem Gesamt-Inhalt vergleichen:
' Dabei wird untersucht, ob in beiden Ordnern alle Sub-Ordner
' da sind und gleiche Größe haben. Außer den evtln. Unterord-
' nern wird die Anwesenheit der einzelnen Dateien verglichen
' und, ob diese Dateien in Datum und in Größe übereinstimmen.
' Sind irgendwo Unterschiede, erfolgt Meldung u. der Abbruch!
' Es sind also Ordner mit - und auch ohne Sub-Ordner prüfbar!
'************************************************************
' CopyRight, W. Schmelz, 05.02.2009
' Eine MsgBox zum Vorstellen dieses Programmes :
'***********************************************
UV=VbCR&VbCR
Titel=" Zwei Ordner in ihrem Inhalt vergleichen !"
Ask=MsgBox (UV&UV&VbTab&"Bitte gleich zwei Ordner"&_
" aussuchen, deren "&UV&VbTab&_
"Inhalt miteinander verglichen werden soll !"&UV&VbTab&_
"Dateien, Größe und Datum werden geprüft !"&UV&VbTab&_
"Genauso evtl. vorhandene Unterordner !"&_
UV&UV&VbCR,VbOkCancel,Titel)
If Ask="2" then WScript.Quit
' Die Objekte u.a. für das Programm bereit stellen :
'***************************************************
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Wss=WScript.CreateObject("WScript.Shell")
Dim Pfad1, Pfad2, Zahl1, Zahl2, Datum1(), Datum2(), k
Dim Datum3(), Datum4(), Diff, Gros
' Den 1. Ordner in einem Browser aussuchen :
'*******************************************
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
' Die Dateien im Ordner 1 werden gezählt :
'*****************************************
Set Data=Fso.GetFolder(Pfad1)
Zahl1=Data.Files.Count
Zahl11=Data.SubFolders.Count
If (Zahl1="0" and Zahl11="0") then
MsgBox UV&UV&"Der Ordner "&Pfad1&" ist leer !"&_
" "&UV&UV,VbCritical,Titel:WScript.Quit
End If
' Den 2. Ordner in einem Browser aussuchen :
'*******************************************
Wss.Popup UV&UV&VbCR&VbTab&_
"Bitte den 2. Datei-Ordner aussuchen !"&_
" "&_
UV&UV&VbCR,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
' Sind diese beiden Ordner wirklich verschieden ?
'************************************************
If Pfad1=Pfad2 then
MsgBox UV&UV&_
"Es wurden nicht zwei verschiedene Ordner ausgewählt !"&_
" "&UV&UV,VbCritical,Titel:WScript.Quit
End If
' Die Dateien im Ordner 2 werden gezählt :
' ****************************************
Set Data=Fso.GetFolder(Pfad2)
Zahl2=Data.Files.Count
Zahl21=Data.SubFolders.Count
If (Zahl2="0" and Zahl21="0") then
MsgBox UV&UV&"Der Ordner "&Pfad2&" ist leer !"&_
" "&UV&UV,VbCritical,Titel:WScript.Quit
End If
' Die Kontroll - Meldung, welche Ordner ausgesucht wurden :
'**********************************************************
Msg=MsgBox (UV&VbTab&"Folgende beiden Datei - Ordner :"&_
UV&VbCR&VbTab&Pfad1&UV&VbTab&Pfad2&UV&VbCR&VbTab&_
"wurden gerade ausgesucht !"&VbCR&VbTab&"Sie werden "&_
"jetzt verglichen ! "&UV&VbCR,VbOkCancel,Titel)
If Msg="2" then WScript.Quit 'Abbruch auf Wunsch
'***************************************************
' Der Abbruch, wenn die Ordner - Größen gleich sind,
' da dann mit größter Sicherheit die Ordner gleich !
'***************************************************
Set Folder1=Fso.GetFolder(Pfad1)
Set Folder2=Fso.GetFolder(Pfad2)
Size1=Folder1.Size
Size2=Folder2.Size
If Size1=Size2 then
Ask=MsgBox (UV&UV&_
"Die beiden Ordner haben die gleiche Größe ! "&_
UV&"Sie sind daher mit größter Sicherheit gleich !"&_
UV&"Soll trotzdem das Programm weiter prüfen ?"&_
UV&UV,VbOkCancel+VbInformation,Titel)
If Ask="2" then WScript.Quit 'Auf Wunsch der Abbruch
End If
' Die Ordner 1 und Ordner 2 auf ihre Unterordner analysieren:
'************************************************************
Set Fs1=Fso.GetFolder(Pfad1)
Set Inhalt1=Fs1.SubFolders 'Unter-Ordner auflisten
Set Fs2=Fso.GetFolder(Pfad2)
Set Inhalt2=Fs2.SubFolders 'Unter-Ordner auflisten
'Prüfen, ob Unterordner-Größen gleich oder im 2. einer fehlt:
'************************************************************
Diff="" 'Ungleiche Unterordner sammeln
For each i in Inhalt1
Stelle1=InStrRev(i,"\")
Ordn1=Right(i,Len(i)-Stelle1)
Dort="0" 'Prüfen, ob Unterordner fehlen
For each k in Inhalt2
Stelle2=InStrRev(k,"\")
Ordn2=Right(k,Len(k)-Stelle2)
If Ordn1=Ordn2 and not i.Size=k.Size then _
Diff=Diff&Ordn1&VbCR 'Ungleiche Unterordner sammeln !
If Ordn1=Ordn2 then Dort="1" 'Alle die Unterordner vorhanden?
Next
If Dort<>"1" then Fehlt1=Fehlt1&Ordn1&VbCR'Fehl. Unterordner?
Next
' Prüfen, ob Unterordner alle gleich oder im 1. einer fehlt :
'************************************************************
For each i in Inhalt2
Stelle2=InStrRev(i,"\")
Ordn2=Right(i,Len(i)-Stelle2)
Dort="0" 'Prüfen, ob Unterordner fehlen
For each k in Inhalt1
Stelle1=InStrRev(k,"\")
Ordn1=Right(k,Len(k)-Stelle1)
If Ordn2=Ordn1 then Dort="1" 'Alle die Unterordner vorhanden?
Next
If Dort<>"1" then Fehlt2=Fehlt2&Ordn2&VbCR'Fehl. Unterordner?
Next
' Abbruch, wenn Unterordner-Größen oder deren Inhalt ungleich :
'**************************************************************
If Fehlt1<>"" then MsgBox UV&UV&" Folgende Unterordner "&_
"des 1. sind nicht im 2. Ordner: "&UV&Fehlt1&UV&VbCR,, _
" Fehlende Unter-Ordner sind :"
If Fehlt2<>"" then MsgBox UV&UV&" Folgende Unterordner "&_
"des 2. sind nicht im 1. Ordner: "&UV&Fehlt2&UV&VbCR,, _
" Fehlende Unter-Ordner sind :"
If Diff<>"" then MsgBox UV&VbCR&" Folgende Unterordner "&_
"haben ungleiche Größe: "&UV&Diff&UV&VbCR,, _
" Ungleiche Unter-Ordner sind :"
If (Fehlt1<>"" or Fehlt2<>"" or Diff<>"") then WScript.Quit
' Namen und Datum aller Einzel-Dateien des 1. Ordner ermitteln :
'***************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
ReDim Preserve Datum1(Zahl1)
k=1
For each i in Data
Datum=Left(i.DateLastModified,19)
'Jahr, Monat, Tag, Std, Min, Sek der letzten Bearbeitung:
Tag=Left(Datum,2)
Monat=Mid(Datum,4,2)
Jahr=Mid(Datum,7,4)
Std=Mid(Datum,12,2)
Min=Mid(Datum,15,2)
Sek=Mid(Datum,18,2)
Datum1(k)=i&Jahr&Monat&Tag&Std&Min&Sek 'Name & Datum
k=1+k
Next
' Namen und Datum der Einzel - Dateien des 2. Ordner ermitteln :
'***************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
ReDim Preserve Datum2(Zahl2)
k=1
For each i in Data
Datum=Left(i.DateLastModified,19)
'Jahr, Monat, Tag, Std, Min, Sek der letzten Bearbeitung:
Tag=Left(Datum,2)
Monat=Mid(Datum,4,2)
Jahr=Mid(Datum,7,4)
Std=Mid(Datum,12,2)
Min=Mid(Datum,15,2)
Sek=Mid(Datum,18,2)
Datum2(k)=i&Jahr&Monat&Tag&Std&Min&Sek 'Name & Datum
k=1+k
Next
' Den Namen und Größe aller Dateien des 1. Ordner ermitteln :
'************************************************************
Set Data=Fso.GetFolder(Pfad1).Files
ReDim Preserve Datum3(Zahl1)
k=1
For each i in Data
Datum3(k)=i&"#"&i.Size 'Name & Größe
k=1+k
Next
' Den Namen und Größe aller Dateien des 2. Ordner ermitteln :
'************************************************************
Set Data=Fso.GetFolder(Pfad2).Files
ReDim Preserve Datum4(Zahl2)
k=1
For each i in Data
Datum4(k)=i&"#"&i.Size 'Name & Größe
k=1+k
Next
' Welche Dateien im 1. Ordner haben andere Größe als im 2. ?
'***********************************************************
Anders=""
For i=1 to Zahl1
For k=1 to Zahl2
Stelle1=InStr(Datum3(i),"#")
Stelle2=InStr(Datum4(k),"#")
If (Fso.GetFileName(Left(Datum3(i),Stelle1-1))= _
Fso.GetFileName(Left(Datum4(k),Stelle2-1)) and _
not Right(Datum3(i),Len(Datum3(i))-Stelle1)= _
Right(Datum4(k),Len(Datum4(k))-Stelle2)) then _
Gros=Gros&Fso.GetFileName _
(Left(Datum3(i),Stelle1-1))&VbCR
Next
Next
'***********************************************************
' Welche Dateien im 1. Ordner haben anderes Datum als im 2.?
' Geprüft wird, ob der Unterschied mehr als 3 Sek. beträgt !
' Es muss Jahr&Monat&Tag&Std gleich, Min&Sek bis auf 3 Sek.!
' Erlaubt ist auch genau 1 Std Verschiebung- SWZeit-Wechsel?
'***********************************************************
Anders=""
For i=1 to Zahl1
For k=1 to Zahl2
'Wie kann man 07:59 und 8:01 vergleichen !?
'Dazu erst die Minuten in Sek. ausdrücken!
Min1=Left(Right(Datum1(i),4),2)*60
Min2=Left(Right(Datum2(k),4),2)*60
Min0=Min1-Min2
Std1=Left(Right(Datum1(i),6),2)
Std2=Left(Right(Datum2(k),6),2)
If Fso.GetFileName(Left(Datum1(i),Len(Datum1(i))-14))= _
Fso.GetFileName(Left(Datum2(k),Len(Datum2(k))-14)) and _
(Left(Right(Datum1(i),14),8)<>Left(Right(Datum2(k),14),8) _
or abs(Min0+Right(Datum1(i),2)-Right(Datum2(k),2))>3 _
or abs(Std1-Std2)>1) _
then Anders=Anders&Fso.GetFileName _
(Left(Datum1(i),Len(Datum1(i))-14))&VbCR
Next
Next
' Welche Dateien aus dem 1. Ordner sind nicht im 2. Ordner ?
'***********************************************************
Set Data=Fso.GetFolder(Pfad1).Files
Neu1=""
For each File in Data
If not Fso.FileExists(Pfad2&"\"&Fso.GetFileName(File)) _
then Neu1=Neu1&Fso.GetFileName(File)&VbCR
Next
' Welche Dateien aus dem 2. Ordner sind nicht im 1. Ordner ?
'***********************************************************
Set Data=Fso.GetFolder(Pfad2).Files
Neu2=""
For each File in Data
If not Fso.FileExists(Pfad1&"\"&Fso.GetFileName(File)) _
then Neu2=Neu2&Fso.GetFileName(File)&VbCR
Next
'Die Meldung zum Ergebnis des Vergleiches der beiden Ordner:
'***********************************************************
Txt=Txt&UV
If Neu2<>"" then Txt=Txt&" Im 1. Ordner sind diese "&_
"Dateien des 2. Ordner nicht vorhanden: "
If Neu2<>"" then Txt=Txt&VbCR&Neu2&VbCR
If Neu1<>"" then Txt=Txt&" Im 2. Ordner sind diese "&_
"Dateien des 1. Ordner nicht vorhanden:"
If Neu1<>"" then Txt=Txt&VbCR&Neu1&VbCR
If Gros<>"" then
Txt=Txt&" Im 2. "&_
"Ordner haben diese Dateien andere Größe als im 1. : "
Txt=Txt&VbCR&Gros
Txt=Txt&VbCR
End If
If Anders<>"" then
Txt=Txt&" Im 2. "&_
"Ordner haben diese Dateien anderes Datum als im 1.: "
Txt=Txt&VbCR&Anders
End If
Txt=Txt&VbCR
If (Neu1="" and Neu2="" and Anders="" and Gros="") then
MsgBox UV&VbCR&VbTab&_
" Alles O K !"&_
VbCR&" In den Ordnern sind gleiche Dateien "&_
"mit gleichem Datum ! "&UV&UV,,Titel
else
MsgBox Txt,,Titel
End If
#########################################################################
>>> patchlist.vbs <<<
'v5.A*****************************************************
' File: patchlist.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'
' Listet die installierten MS-Patches.
'
'*********************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WshSysEnv : Set WshSysEnv = WshShell.Environment("Process")
Dim objWMIService, colItems, objItem, i
Dim ZielDatei : ZielDatei = WshSysEnv("SYSTEMROOT") & "\System32\Logs\" & WshNet.ComputerName & " Patchlist.txt"
ZielDatei = WshShell.Environment("Process")("Temp") & "\" & WshNet.ComputerName & " Patchlist.txt"
Dim FileOut : Set FileOut = fso.OpenTextFile( ZielDatei, 8, true) ' 2: immer anlegen
FileOut.WriteLine( vbCRLF & """" & ZielDatei & """ wird ermittelt am " & Now() )
' On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_QuickFixEngineering",,48)
For Each objItem in colItems
If Len ( objItem.ServicePackInEffect ) > 5 Then i=i+1 : FileOut.WriteLine( i & vbTab & objItem.ServicePackInEffect )
Next
FileOut.WriteLine( """" & ZielDatei & """ wurde ermittelt am " & Now() )
FileOut.Close
Set FileOut = nothing
WSHShell.Run "Notepad " & ZielDatei
#########################################################################
>>> pc-analyse.vbs <<<
'*** v8.8 *** www.dieseyer.de ******************************
'
' Datei: pc-analyse.vbs
' Autor: W.Schmelz
' Auf: www.dieseyer.de
'
'Kleine " PC-Analyse.vbs ", nur für das Wichtigste !
'Alles wurde bisher nur für Windows XP programmiert!
'In Vista fehlen z.Zt. Gesamt-Ram-Größe, Grafikkarte!
'In Me kommen nur Win-Version, Ort und Eigentümer, da
'sich das Programm in dieser Form sonst festfrisst!
'
'Analysiert Festplatten, auch USB, die DVD-Laufwerke,
'Laufwerksbelegungen, aktuelle und gesamte RAM-Größe,
'Wichtiges zur CPU, die Win - Version, ihren Ort, den
'registrierten Eigentümer, zum Schluss wird noch die
'Grafikkarte nachgesehen.
'Es wird alles in " PC-Analyse.vbs.txt " geschrieben,
'die Datei geöffnet und anschließend wieder gelöscht!
'***********************************************************
'Copyright W. Schmelz, 01.05.2008
'Die Objekte bereit stellen:
'***************************
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=CreateObject("Scripting.FileSystemObject")
Set Lwk=Fso.Drives
Set Wmg=GetObject ("Winmgmts:").ExecQuery("Select"&_
" * from Win32_OperatingSystem")
Set CpuSet=GetObject("Winmgmts:").InstancesOf("Win32_Processor")
UV=VbCR&VbCR
'Evtle. Fehler übergehen, damit Programm durchläuft:
'***************************************************
On Error Resume next 'Fehlermeldungen abschalten
'**********************************************
'Windows-Version, Ort und Eigentümer ermitteln:
'**********************************************
CheckKey="HKLM\Software\Microsoft\Windows NT\"&_
"CurrentVersion\ProductName"
Version=Wss.RegRead(CheckKey)
CheckKey="HKLM\Software\Microsoft\Windows NT\"&_
"CurrentVersion\SystemRoot"
Ort=Wss.RegRead(CheckKey)
CheckKey="HKLM\Software\Microsoft\Windows NT\"&_
"CurrentVersion\RegisteredOwner"
Name=Wss.RegRead(CheckKey)
'Falls keine Version gefunden, mit ME versuchen:
If Version="" then
CheckKey="HKLM\Software\Microsoft\Windows\"&_
"CurrentVersion\Productname"
Version=Wss.RegRead(CheckKey)
End If
'Windows - Version festlegen:
'****************************
Win=LCase(Mid(Version,19,2))' me, xp, vi ist möglich!
If Win="me" then
CheckKey="HKLM\Software\Microsoft\Windows\"&_
"CurrentVersion\SystemRoot"
Ort=Wss.RegRead(CheckKey)
CheckKey="HKLM\Software\Microsoft\Windows\"&_
"CurrentVersion\RegisteredOwner"
Name=Wss.RegRead(CheckKey)
'Bei Windows ME Schluss - Meldung und Abbruch:
'*********************************************
MsgBox UV&VbTab&_
Version&" / "&Ort&" / "&Name&UV&VbTab&"Da Windows ME "&_
"vorliegt, wird hier abgebrochen! "&_
UV,," Geht leider nicht weiter !"
Wscript.Quit
End If
'Es liegt nicht Windows XP oder Vista vor, dann Abbruch:
'*******************************************************
If not (Win="xp" or Win="vi") then
MsgBox UV&VbTab&_
"Es liegt nicht Windows XP oder Vista vor ,"&UV&VbTab&_
"daher muss hier abgebrochen werden ! "&_
UV,," Geht leider nicht weiter !"
Wscript.Quit
End If
'**********************************************
'Festplatten ermitteln, CD/DVD:
'******************************
'Festplatten ermitteln, auch USB:
i=0
Do until (i=8 or Ende="1")
ReDim Preserve Platte(i)
Key="HKLM\System\ControlSet001\Services\Disk\Enum\"&i
Platte(i)=Wss.RegRead(Key)
'Name auf Wesentliches beschränken, "___ .." abschneiden:
If Platte(i)="" then Ende="1"
Schluss="0"
a=1
Do until (a=Len(Platte(i))-2 or Schluss="1" or Ende="1")
If Mid(Platte(i),a,3)="___" then
Platte(i)=Left(Platte(i),a-1)
Schluss="1"
End If
a=a+1
Loop
i=i+1
Loop
'DVD-Laufwerke ermitteln:
CheckKey="HKLM\System\CurrentControlSet\Services\Cdrom\Enum\0"
CDR1=Wss.RegRead(CheckKey)
'Name auf Wesentliches beschränken, "___ ..." abschneiden:
Schluss="0"
a=1
Do until (a=Len(CDR1)-2 or Schluss="1")
If Mid(CDR1,a,3)="___" then
CDR1=Left(CDR1,a-1)
Schluss="1"
End If
a=a+1
Loop
CheckKey="HKLM\System\CurrentControlSet\Services\Cdrom\Enum\1"
CDR2=Wss.RegRead(CheckKey)
'Name beschränken:
If CDR2="" then Ende="1"
Schluss="0"
a=1
Do until (a=Len(CDR2)-2 or Schluss="1" or Ende="1")
If Mid(CDR2,a,3)="___" then
CDR2=Left(CDR2,a-1)
Schluss="1"
End If
a=a+1
Loop
'**********************************************
'Ergebnisse in Datei schreiben, evtl. erst anlegen und öffnen!
'*************************************************************
'(Datei wird am Ende nach den Eintragungen wieder geschlossen!)
Set Data=Fso.CreateTextFile(WScript.ScriptName&".txt",8,true)
Data.WriteLine("")
Data.WriteLine("")
Data.Write(" **************************************")
Data.WriteLine("*****************************")
Data.Write(" Diese vom Programm geschriebene Datei wurde ")
Data.WriteLine("sofort wieder gelöscht!")
Data.Write(" Wenn sie aufbewahrt werden soll, ")
Data.WriteLine("einfach erneut speichern!")
Data.Write(" **************************************")
Data.WriteLine("*****************************")
'Kopf der Analyse-Datei:
'***********************
Data.WriteLine("")
Data.WriteLine(" Kleinere Analyse des PC von :")
Data.WriteLine(" *****************************")
Data.WriteLine(" "&Name)
Data.WriteLine("")
Data.WriteLine("")
'**********************************************
'Name und Ort der Windows - Version eintragen:
'*********************************************
Data.WriteLine("")
Data.WriteLine(" Name und Ort der Windows - Version:")
Data.WriteLine(" ***********************************")
Data.WriteLine(" "&Version&" in "" "&Ort&" """)
Data.WriteLine("")
'**********************************************
'Die CD / DVD - Laufwerke im PC:
'*******************************
Data.WriteLine("")
Data.WriteLine(" CD / DVD - Laufwerke im PC heißt(en):")
Data.WriteLine(" *************************************")
If Len(CDR1)<40 then Data.WriteLine(" "&CDR1)
If Len(CDR1)>=40 then Data.WriteLine(" "&CDR1)
If not CDR2="" then
Data.WriteLine("")
If Len(CDR2)<40 then Data.WriteLine(" "&CDR2)
If Len(CDR2)>=40 then Data.WriteLine(" "&CDR2)
End If
'**********************************************
'Alle vorhandenen Laufwerke aufschreiben, ggf. USB:
'**************************************************
Data.WriteLine("")
Data.WriteLine("")
Data.WriteLine(" Die Festplatte(n) im PC heißt(en) :")
Data.WriteLine(" ***********************************")
'Platten aufschreiben, ca. mittig setzen
k=0
Do until Platte(k)=""
If Len(Platte(k))<40 then
Data.WriteLine(" "&Platte(k))
End If
If Len(Platte(k))>=40 then Data.WriteLine(" "&Platte(k))
Data.WriteLine("")
k=k+1
Loop
'**********************************************
'Die Belegungen der Laufwerke ermitteln und notieren:
'****************************************************
Data.WriteLine("")
Data.WriteLine("")
Data.WriteLine(" ****************************************")
Data.Write(" ")
Data.WriteLine("Die Belegungen der PC - Laufwerke sind :")
Data.WriteLine(" ****************************************")
Data.WriteLine("")
For each i in Lwk ' <===== Anfang der Schleife!!!
Txt=""
Txt1=""
Txt2=""
Proz=""
If i.DriveType=1 then Txt=" Wechsel-Lw. "&i.DriveLetter&": "
If i.DriveType=2 then Txt=" Festplatte "&i.DriveLetter&": "
If i.DriveType=4 then ' Keine "Voll!" - Warnung bei CD o.ä.
Txt=" CD-Laufwerk "&i.DriveLetter&": "
Achtng="CDLwk"
End If
Txt1=" Es sind "&FormatNumber(i.FreeSpace,0)&" Bytes "&_
"("&FormatNumber(i.FreeSpace/2^30,6)&" GB) von "
Txt2=" "&FormatNumber(i.TotalSize,0)&" Bytes ("&_
FormatNumber(i.TotalSize/2^30,6)&" GB) noch übrig !"
Proz=Left(FormatNumber(i.FreeSpace)*100/FormatNumber(i.TotalSize),4)
'Warnung, wenn weniger als 10 % Rest geblieben:
'**********************************************
If not Proz="" then
If (Proz<10 and not Achtng="CDLwk") then
MsgBox VbCR&VbCR&"Das Speichermedium "&i&" hat nur noch "&Proz&_
" % Restanteil ! ! ! "&VbCR&VbCR,VbCritical, _
" PC - Analyse"
End If
End If
'Sinnvolle Ergebnisse aufschreiben:
'**********************************
If not Proz="" then
Data.Write(Txt)
Data.WriteLine(Txt1)
Data.WriteLine(Txt2)
Data.WriteLine("")
Data.Write(" Damit sind ")
Data.Write(Proz)
Data.WriteLine(" % des Laufwerkes frei !")
Data.WriteLine("")
End If
Next ' <===== Ende der Schleife !!!
'**********************************************
'Den freien Speicher ermitteln:
'******************************
For each Objekt in Wmg
FreiRam=Objekt.FreePhysicalMemory
Next
Zahl1=Round(FreiRam/2^10,0)
If Len(Zahl1)=3 then Zahl1=Zahl1&" "
If Len(Zahl1)=2 then Zahl1=Zahl1&" "
'Den Gesamtspeicher ermitteln:
'*****************************
Set Obj=GetObject("Winmgmts:\\"&StrComputer)
Set ObjectSet=Obj.InstancesOf("Win32_LogicalMemoryConfiguration")
For each Object in ObjectSet
Zahl=Object.TotalPhysicalMemory
Next
Zahl2=Round(Zahl/2^10,0)
If Len(Zahl2)=3 then Zahl2=Zahl2&" " 'vierstellig machen
'Prozentuale Anteile des Speichers berechnen, alles schreiben:
'*************************************************************
Zahl3=Round(((Zahl2-Zahl1)/Zahl2)*100,1)
Zahl3=100-Zahl3
If Len(Zahl3)=2 then Zahl3=Zahl3&",0" 'vierstellig machen!
If Len(Zahl3)=1 then Zahl3=Zahl3&",00"
Data.WriteLine("")
Data.WriteLine("")
Data.WriteLine(" *******************************************")
Data.WriteLine(" Die aktuelle Belegung des RAM - Speichers :")
Data.WriteLine(" *******************************************")
Data.WriteLine("")
Data.Write(" Im RAM - Speicher sind ")
Data.WriteLine(Zahl2-Zahl1&" von "&Zahl2&" MB belegt !")
Data.WriteLine("")
Data.Write(" ==> "&Zahl3)
Data.WriteLine(" % des gesamten Speichers sind noch frei !")
Data.WriteLine("")
'**********************************************
'CPU-Frequenz, ihren Namen in Registry auslesen und schreiben:
'*************************************************************
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\0\~MHz"
Wert0=Wss.RegRead(CheckKey)&" MHz"
'Doppel-Prozessor?
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\1\~MHz"
Wert1=Wss.RegRead(CheckKey)
CheckKey="HKLM\Hardware\Description\"&_
"System\CentralProcessor\0\ProcessorNameString"
CpuName=Wss.RegRead(CheckKey)
'Falls Doppel-Prozessor vorliegt:
If not Wert1="" then Wert0=" 2 x "&Wert0&" ( Core 2 CPU )"
Data.WriteLine("")
Data.WriteLine("")
Data.WriteLine(" ****************************************************")
Data.WriteLine(" Die CPU-Frequenz, der CPU - Name und die Auslastung:")
Data.WriteLine(" ****************************************************")
Data.WriteLine("")
Data.WriteLine(" "&Wert0)
Data.WriteLine("")
Data.WriteLine(" "&CpuName)
'Momentane Auslastung der CPU in Prozent:
'****************************************
Doppel="0"
For each Cpu in CpuSet
If CpuSet.Count>1 then
Last=Last+Cpu.LoadPercentage 'Doppel-CPU
Doppel="1"
else
Last=Cpu.LoadPercentage 'Einzel-CPU
End If
Next
If Doppel="1" then Last=Last/2
'Ergebnisse ausgeben:
'********************
'(Leerstellen bei Last nötig!?)
If Doppel="0" then
Data.WriteLine("")
Data.WriteLine(" Momentane CPU-Auslastung ist z.Zt.: "& Last &" %")
End If
If Doppel="1" then
Data.WriteLine("")
Data.WriteLine(" Auslastung der Doppel-CPU ist z.Zt.: "& Last &" %")
End If
'**********************************************
'Die Grafikkarte auslesen und angeben:
'*************************************
If Win="xp" then
CheckKey="HKLM\System\CurrentControlSet\Services\nv\Device0\"&_
"Device Description"
Grafik=Wss.RegRead(CheckKey)
End If
If Win="vi" then
CheckKey="HKLM\System\CurrentControlSet\Services\nv\Device0\"&_
"Device Description" ' ?????????????????????????????
Grafik=Wss.RegRead(CheckKey)
End If
Data.WriteLine("")
Data.WriteLine("")
Data.WriteLine("")
Data.WriteLine(" ********************************")
Data.WriteLine(" Der Name der Grafikkarte lautet:")
Data.WriteLine(" ********************************")
Data.WriteLine("")
Data.WriteLine(" "&Grafik)
Data.WriteLine("")
'********************************************************
Data.Close 'Analyse-Datei schließen!
On Error GoTo 0 'Fehlermeldungen wieder einschalten
'********************************************************
'Die Analyse-Datei öffnen:
'*************************
WScript.Sleep 500
Wss.Run WScript.ScriptName&".txt"
'Analyse-Datei zum Schluss löschen:
'**********************************
WScript.Sleep 3000
Fso.DeleteFile WScript.ScriptName&".txt"
WScript.Sleep 500
WScript.Quit
#########################################################################
>>> pc-aus-w9x.vbs <<<
'v2.3*****************************************************
' File: pc-aus-w9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' 1. Scandisk über alle Laufwerke
' 2. Defragmetierung über alle Laufwerke
' 3. ShutDown mit Ausschalten
'*********************************************************
Option Explicit
DIM WshShell, OpSys, RegKey, TextX, ZielSys, NT_9x, Text
Set WshShell = WScript.CreateObject("WScript.Shell")
' ----------------------------------------------
' Testen der Windows-Version (XP nicht getestet)
' ----------------------------------------------
OpSys = ""
' Win9x/ME?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows\CurrentVersion\Productname")
End if
On Error GoTo 0
If not OpSys = "" Then
WshShell.Run "scandskw /allfixeddisks /noninteractive /silent",,True
WshShell.Run "defrag /all /f /p /noprompt",,True
' Neustart
' WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 7"
' Ausschalten
WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 13"
WScript.Quit
End If
' WinNT?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = "Windows NT " & WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
End if
On Error GoTo 0
' Win2k?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\Productname")
End if
On Error GoTo 0
MsgBox OpSys & " wird nicht unterstützt.", , WScript.ScriptName
#########################################################################
>>> pc-ein-test.vbs <<<
'v4.7***************************************************
' File: pc-ein-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Das Script prüft alle 60s per PING, ob ein PC einge-
' schaltet ist. Der Test beendet sich selbst, wenn die
' .run - Datei gelöscht wird.
'*******************************************************
Option Explicit
Dim PC, Txt, Text, i, Intervall, LogDatei, VBSrun, NetSend
Dim WSHShell, WSHNet, fso
Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
Set Prog_PP = nothing
Set WSHNet = WScript.CreateObject("WScript.Network")
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Intervall = 10
Intervall = 20
PC = "MeinPC"
PC = wshnet.ComputerName
PC = InputBox( "Welcher PC soll auf Anwesenheit überprüft werden?", WScript.ScriptName, PC )
PC = UCase( PC )
If Len( PC ) < 3 then
PC = InputBox( "Welcher PC soll auf Anwesenheit überprüft werden?", WScript.ScriptName, PC )
PC = UCase( PC )
If Len( PC ) < 3 then WScript.Quit
End If
NetSend = "Bitte rufen Sie 0172/74620xx an und verlangen Sie einen Service-Techniker."
LogDatei = PC & " " & WScript.ScriptName & ".log"
VBSrun = PC & " " & WScript.ScriptName & ".run"
fso.OpenTextFile(LogDatei, 8, true).WriteLine ( now() )
fso.OpenTextFile(VBSrun , 8, true).WriteLine ( now() )
Do
Txt = ExecHiddenPlus ( "%comspec% /c Ping " & PC & " -n 1" ) ' PING absetzen
Txt = Split(Txt, vbCrLf ) ' alles von PING gelesene in Zeilen aufteilen
Text = ""
for i = 0 to ubound(Txt) ' jede Zeile überprüfen
if InStr(Txt(i), "TTL=") > 1 then Text = Txt(i)
next
fso.OpenTextFile(LogDatei, 8, true).WriteLine ( Text & vbTab & PC & vbTab & now() )
' LOG schreiben
If InStr( UCase( Text ), "TTL" ) then ' enthält PING-Ausgabe TTL?
Text = MsgBox( now() & vbCRLF & PC & " reagiert auf PING mit:" & vbCRLF & vbCRLF & Text, 5+4096, WScript.ScriptName )
If Text = vbCancel Then Exit Do
End If
If not fso.FileExists( VBSrun ) then ' wurde .run - Datei gelöscht?
Text = MsgBox( now() & vbCRLF & PC & vbCRLF & vbCRLF & "Nicht erreichbar - Test abgebrochen.", 5+4096, WScript.ScriptName )
If Text = vbCancel Then WScript.Quit
fso.OpenTextFile(VBSrun , 8, true).WriteLine ( now() )
End If
If not Text = vbRetry Then WScript.Sleep 1000 * Intervall ' ..Sekunden warten
If not fso.FileExists( VBSrun ) then ' wurde .run - Datei gelöscht?
Text = MsgBox( now() & vbCRLF & PC & vbCRLF & vbCRLF & "Nicht erreichbar - Test abgebrochen.", 5+4096, WScript.ScriptName )
If Text = vbCancel Then WScript.Quit
fso.OpenTextFile(VBSrun , 8, true).WriteLine ( now() )
End If
Loop
NetSend = InputBox( "Eine Nachricht an " & PC & " senden?", WScript.ScriptName & vbTab & PC, NetSend )
NetSend = " " & NetSend ' ein Leerzeichen einfügen
If not NetSend = "" Then
WSHShell.Run "net send " & PC & NetSend
fso.OpenTextFile(LogDatei, 8, true).WriteLine ( "net send " & PC & NetSend & vbTab & now() )
' LOG schreiben
Else
wshshell.Popup "net send " & PC & NetSend & vbCRLF & ". . . wurde nicht abgesetzt." , 12, WScript.ScriptName
fso.OpenTextFile(LogDatei, 8, true).WriteLine ( "KEIN net send " & PC & NetSend & vbTab & now() )
End If
If fso.FileExists( VBSrun ) Then fso.DeleteFile( VBSrun )
wshshell.Popup "Ende" , 5, WScript.ScriptName
WScript.Quit
'**************************************************************
Function ExecHiddenPlus ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
Dim FileOut, oWsh, Tmp
Tmp = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & PC & "-ExecHiddenPlus.VBS"
If not WScript.CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
' zum Test nächste Zeile frei geben
' MsgBox Tmp & vbCRLF & "F E H L T"
Set FileOut = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 8, true)
FileOut.WriteLine( " set oArgs = Wscript.Arguments " )
FileOut.WriteLine( " For i = 0 to oArgs.Count - 1 " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox oArgs.item(i) , , WScript.ScriptName & "" - oArgs "" " )
FileOut.WriteLine( " if Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & """""""" & oArgs.item(i) & """""""" & "" "" " )
FileOut.WriteLine( " if not Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & oArgs.item(i) & "" "" " )
FileOut.WriteLine( " Next " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox CMD , , WScript.ScriptName & "" Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec( CMD ) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""volatile"" )( ""Eregbnis"" ), , WScript.ScriptName & "" Ende "" " )
FileOut.Close
Set FileOuT = nothing
End If
Set oWsh = WScript.CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp & " " & CMD , 0, true
ExecHiddenPlus = oWsh.Environment("volatile")( "Eregbnis" )
' zum Test nächste Zeile frei geben - Löschen der 'Tmp-Datei
WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHiddenPlus ( CMD ) ' v3.A - http://dieseyer.de
'**************************************************************
#########################################################################
>>> pc-im-ad.vbs <<<
'*** v8.2 *** www.dieseyer.de *******************************
'
' Datei: pc-im-ad.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Gibt den 'distinguishedName' eines PCs zurück. Das AD wird
' dazu nicht mit einer For..Each-Schleife durchlaufen, bis
' der PC gefunden wird, sonder es wird 'direkt' gefragt.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst, Txt
Dim StartZeit
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim PC : PC = WSHNet.ComputerName
Dim AD
AD = "LDAP://ou=HR,dc=NA,dc=fabrikam,dc=com"
AD = "LDAP://dc=fabrikam,dc=com"
Txt = PCimAD( AD, PC ) ' Prozedur-Aufruf'
Txt = LCase( Txt )
Txt = Replace( Txt, "ldap://", "" )
Txt = Replace( Txt, "cn=", "" )
Txt = Replace( Txt, "ou=", "" )
Txt = Replace( Txt, "dc=", "" )
Txt = Replace( Txt, ",", "." )
MsgBox "AD-Objekt: " & Txt
' StartZeit = Timer() : Tst = "PC13-08" : Txt = PCimAD( AD, Tst ) : MsgBox "Dauer: " & Timer() - Startzeit & vbCRLF & Tst & vbCRLF & PCimAD( AD, Tst ), , "33 :: "
' StartZeit = Timer() : Tst = "PC0815" : Txt = PCimAD( AD, Tst ) : MsgBox "Dauer: " & Timer() - Startzeit & vbCRLF & Tst & vbCRLF & PCimAD( AD, Tst ), , "34 :: "
' StartZeit = Timer() : Tst = "PC-GIBTSNICHT" : Txt = PCimAD( AD, Tst ) : MsgBox "Dauer: " & Timer() - Startzeit & vbCRLF & Tst & vbCRLF & PCimAD( AD, Tst ), , "35 :: "
WScript.Quit
'*** v8.2 *** www.dieseyer.de *******************************
Function PCimAD( AD, PCname )
'************************************************************
' On Error Resume Next
Const ADS_SCOPE_SUBTREE = 2
Dim objConnection, objCommand, objRecordSet
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = "SELECT distinguishedName FROM '" & AD & "' WHERE objectCategory='Computer' AND Name='" & PCname & "'"
Set objRecordSet = objCommand.Execute
PCimAD = PCname & " ist nicht im AD vorhanden."
On Error Resume Next
PCimAD = objRecordSet.Fields("distinguishedName").Value
On Error GoTo 0
' MsgBox "i = " & i & vbCRLF & "n = " & n & vbCRLF & "Dauer: " & Timer() - StartZeit & vbCRLF & objRecordSet.Fields("distinguishedName").Value , , "63 :: " ' : WScript.Quit
Set objRecordSet = nothing
Set objCommand.ActiveConnection = nothing
Set objCommand = nothing
objConnection.Close
Set objConnection = nothing
End Function ' PCimAD( AD, PCname )
#########################################################################
>>> pc-info.vbs <<<
'v5.B======================================================================
'
' NAME: pc-info.vbs
'
' AUTHOR: sk0r , VB-Scripter, siehe auch: http://dieseyer.de/images/sk0r.jpg
' DATE : 27.11.2005
' dieseyer.de
'
' COMMENT: Dieses Skript zeig Ihnen Informationen über ihren PC
' This script shows you informations about your computer
'
' Das Skript wertet LOG-Dateien aus:
' s_wshs.run "%comspec% /c set > C:\sk0r_first.log"
' s_wshs.run "%comspec% /c ipconfig > C:\sk0r_second.log"
' s_wshs.run "dxdiag /t C:\sk0r_third.Log"
'==========================================================================
Set s_wshs = CreateObject ("WScript.Shell")
Set s_fso = CreateObject ("Scripting.FileSystemObject")
Set s_network = CreateObject ("WScript.Network")
Set s_windir = s_fso.GetSpecialFolder(0)
S_CLIENT_TITLE = "sk0r's PC Informations Skript ©2005 by sk0r"
S_CLIENT_MSG = "Willkommen zu PC Analyse" +VbCrLf
S_CLIENT_MSG = S_CLIENT_MSG +"================"+VbCrLf
S_CLIENT_MSG = S_CLIENT_MSG + " " +VbCrLf
S_CLIENT_MSG = S_CLIENT_MSG +"Dieses Skript zeigt ihnen Informationen"+VbCrLf
S_CLIENT_MSG = S_CLIENT_MSG +"ueber ihren Computer. Wollen Sie fortsetzten?"+VbCrLf
S_CLIENT_MSG = S_CLIENT_MSG +"Dies kann etwas Zeit in Anspruch nehmen."+VbCrLf
S_QUESTION = MsgBox (S_CLIENT_MSG ,vbYesNo + vbQuestion ,S_CLIENT_TITLE)
If S_QUESTION = vbYes Then
Call skor_gosub()
Elseif S_QUESTION = vbNo Then
s_wshs.popup "Skript wurde durch benutzer abgebrochen",2,"sk0r"
End If
Sub skor_gosub
s_wshs.run "%comspec% /c set > C:\sk0r_first.log"
WScript.sleep 4000
s_wshs.run "%comspec% /c ipconfig > C:\sk0r_second.log"
WScript.sleep 4000
Set s_textone = s_fso.opentextfile ("C:\sk0r_second.log")
While Not s_textone.AtEndOfStream
s_reading = s_textone.readline
If InStr(UCase(s_reading), "IP-ADRESSE") Then
s_ipaddy = Right(s_reading,13)
End If
If InStr(UCase(s_reading),"SUBNETZMASKE") Then
s_subnet = Right(s_reading,15)
End If
If InStr(UCase(s_reading),"STANDARDGATEWAY") Then
s_stdgate = Right(s_reading,13)
End If
Wend
Set s_texttwo = s_fso.opentextfile("C:\sk0r_first.log")
While Not s_texttwo.AtEndOfStream
s_allreading = s_texttwo.readline
If InStr(UCase(s_allreading),"USERPROFILE") Then
s_profil = Right(s_allreading,37)
End If
If InStr(UCase(s_allreading),"PROGRAMFILES") Then
s_pfiles = Right(s_allreading,12)
End If
If InStr(UCase(s_allreading),"OS") Then
s_os = Right(s_allreading,10)
End If
Wend
s_wshs.run "dxdiag /t C:\sk0r_third.Log"
Do Until s_fso.fileexists ("C:\sk0r_third.Log")
WScript.Sleep 10
langweile = langweile + 1
If s_fso.fileexists ("C:\sk0r_third.Log") Then
Set s_textthree = s_fso.OpentextFile ("C:\sk0r_third.Log")
While Not s_textthree.AtEndOfStream
s_readingall = s_textthree.readline
If InStr(UCase(s_readingall),"B RAM") Then
s_ram = Right(s_readingall,9)
End If
If InStr(UCase(s_readingall),"BIOS") Then
s_biover = Right(s_readingall,13)
End If
If InStr(UCase(s_readingall),"DIRECTX VER") Then
s_xver = Right(s_readingall,30)
End If
If InStr(UCase(s_readingall),"CARD NAME") Then
s_gkname = Right(s_readingall,23)
End If
If InStr(UCase(s_readingall),"DISPLAY MEMORY") Then
s_gkmb = Right(s_readingall,9)
End If
If InStr(UCase(s_readingall),"CURRENT MODE") Then
s_modus = Right(s_readingall,28)
End If
If InStr(UCase(s_readingall),"MONITOR:") Then
s_moni = Right(s_readingall,17)
End If
Wend
End If
Loop
's_fso.deletefile ("C:\sk0r_first.log")
's_fso.deletefile ("C:\sk0r_second.log")
's_fso.deletefile ("C:\sk0r_third.Log")
S_END_TITLE = "sk0r's PC Information Skript ©2005 by sk0r"
S_END_MSG = "Zusammenfassung der Informationen" +vbcrlf
S_END_MSG = S_END_MSG +"======================="+VbCrLf
S_END_MSG = S_END_MSG +" "+vbcrlf
S_END_MSG = S_END_MSG +"Computername: "+s_network.computername+vbcrlf
S_END_MSG = S_END_MSG +"Benutzername: "+s_network.username+vbcrlf
S_END_MSG = S_END_MSG +"Ip-Adresse: "+s_ipaddy+VbCrLf
S_END_MSG = S_END_MSG +"Subnetzmaske: "+s_subnet+VbCrLf
S_END_MSG = S_END_MSG +"Standardgateway: "+s_stdgate+VbCrLf
S_END_MSG = S_END_MSG +"Benutzerprofil: "+s_profil+VbCrLf
S_END_MSG = S_END_MSG +"Programm-Ordner: "+s_pfiles+VbCrLf
S_END_MSG = S_END_MSG +"OS: "+s_os+VbCrLf
S_END_MSG = S_END_MSG +"MB Ram: "+s_ram+VbCrLf
S_END_MSG = S_END_MSG +"Bios Version: "+s_biover+VbCrLf
S_END_MSG = S_END_MSG +"DirectX Version: "+s_xver+VbCrLf
S_END_MSG = S_END_MSG +"Grafikkarte: "+s_gkname+VbCrLf
S_END_MSG = S_END_MSG +"GK Speicher: "+s_gkmb+VbCrLf
S_END_MSG = S_END_MSG +"Aufloesung:" +s_modus+VbCrLf
S_END_MSG = S_END_MSG +"Monitor: "+s_moni+VbCrLf
MsgBox (S_END_MSG),vbokonly +vbinformation,S_END_TITLE
End Sub
' <-- END OF VBS/sk0r.PcInformation | © 2005 by sk0r -->
' Für das Skript solltet ihr folgende Voraussetzungen haben:
#########################################################################
>>> pc-restart-w9x.vbs <<<
'v2.3*****************************************************
' File: pc-restart-w9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' 1. Scandisk über alle Laufwerke
' 2. Defragmetierung über alle Laufwerke
' 3. ShutDown mit Neustart
'*********************************************************
Option Explicit
DIM WshShell, OpSys, RegKey, TextX, ZielSys, NT_9x, Text
Set WshShell = WScript.CreateObject("WScript.Shell")
' ----------------------------------------------
' Testen der Windows-Version (XP nicht getestet)
' ----------------------------------------------
OpSys = ""
' Win9x/ME?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows\CurrentVersion\Productname")
End if
On Error GoTo 0
If not OpSys = "" Then
WshShell.Run "scandskw /allfixeddisks /noninteractive /silent",,True
WshShell.Run "defrag /all /f /p /noprompt",,True
' Neustart
WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 7"
' Ausschalten
' WshShell.Run "rundll Shell32.dll,SHExitWindowsEx 13"
WScript.Quit
End If
' WinNT?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = "Windows NT " & WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
End if
On Error GoTo 0
' Win2k?
' ----------------------------------------------
On Error Resume Next
If not err.number <> 0 Then
OpSys = WshShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\Productname")
End if
On Error GoTo 0
MsgBox OpSys & " wird nicht unterstützt.", , WScript.ScriptName
#########################################################################
>>> pckonfiguration-wintuc.vbs <<<
'*** v9.6 *** www.dieseyer.de *******************************
'
' Datei: PC-Konfiguration für WinTuC.vbs
' Datei: PCKonfiguration-WinTuC.vbs
' Autor: xxx.dexter.xxx@googlemail.com
' Auf: www.dieseyer.de / www.wintuc.de
'
' http://www.source-center.de/forum/showthread.php?p=78817
' Diese Dienste sollten auf dem Zielrechner wie folgt konfiguriert sein:
' - Arbeitsstationsdienst: (Starttyp = Automatisch)
' - COM+-Ereignissystem: (Starttyp = Manuell)
' - RAS-Verbindungsverwaltung: (Starttyp = Manuell)
' - Remoteprozeduraufruf (RPC): (Starttyp = Automatisch)
' - Remote-Registrierung: (Starttyp = Automatisch)
' - RPC-Locator: (Starttyp = Manuell)
' - Server: (Starttyp = Automatisch)
' - Treibererweiterung für Windows Verwaltungsinstrumentation: (Starttyp = Manuell)
' - Verwaltung für automatische RAS-Verbindung: (Starttyp = Manuell)
' - Windows-Verwaltungsinstrumentation: (Starttyp = Automatisch)
' - WMI-Leistungsadapter: (Starttyp = Manuell)
'
' Ursprünglich war vorgesehen, die PC-Konfiguration vor dem
' 'Freischalten' für WinTuC zu speichern, um diese ggf.
' zurück stellen zu können.
' Da für das 'Freischalten' an dem PC sehr wahrscheinlich
' eine lokale Anmeldung mit einem Admin-User erforderlich
' ist, kann man gleich WinTuC vom USB-Stick starten - damit
' ist der einmalige WinTuC-Einsatz erledigt. Und soll WinTuC
' mehrmals eingesetzt werden, ist das zurück setzen auf eine
' ältere Konfiguration nicht erforderlich.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDatei : LogDatei = WScript.ScriptFullName & "-" & WSHNet.UserName & "-.log"
' Trace32Log( "-", 0 ) ' erstellt neue LogDatei
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup "= = = S T A R T = = =", 2, "046 :: " & WScript.ScriptName
Trace32Log "047 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "048 :: LogDatei: " & LogDatei, 1
Trace32Log "049 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "050 :: Angemeldeter User: " & WSHNet.UserName, 1
' *** Die "klassische" Authentifizierung von Netzwerkanmeldungen verwenden!
WshShell.RegWrite "HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Control\Lsa\forceguest", "00000000", "REG_DWORD"
Trace32Log "055 :: HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Control\Lsa\forceguest, 00000000, REG_DWORD", 1
WshShell.RegWrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Lsa\forceguest", "00000000", "REG_DWORD"
Trace32Log "057 :: HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Lsa\forceguest, 00000000, REG_DWORD", 1
' *** "Distributed Common Object Model" aktivieren!
WshShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Ole\EnableDCOM", "Y", "REG_SZ"
Trace32Log "061 :: HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Ole\EnableDCOM, Y, REG_SZ", 1
' *** Windows-Firewall konfigurieren
' ->Remoteverwaltung zulassen
Wshshell.Run( "netsh firewall set service type=REMOTEADMIN mode=ENABLE")
Trace32Log "066 :: netsh firewall set service type=REMOTEADMIN mode=ENABLE", 1
' *** Windows-Firewall konfigurieren
' -> Ports öffnen
WshShell.Run( "netsh firewall add portopening protocol=TCP port=135 name=DCOM_TCP mode=ENABLE")
Trace32Log "071 :: netsh firewall add portopening protocol=TCP port=135 name=DCOM_TCP mode=ENABLE", 1
WshShell.Run( "netsh firewall add portopening protocol=TCP port=445 name=SMB_TCP mode=ENABLE")
Trace32Log "073 :: netsh firewall add portopening protocol=TCP port=445 name=SMB_TCP mode=ENABLE", 1
WshShell.Run( "netsh firewall add portopening protocol=TCP port=24158 name=WMI_TCP mode=ENABLE")
Trace32Log "075 :: netsh firewall add portopening protocol=TCP port=24158 name=WMI_TCP mode=ENABLE", 1
WSHShell.Popup "= = = E N D E = = =" & vbCRLF & vbCRLF & WScript.ScriptName, 12, "077 :: " & WScript.ScriptName, vbInformation + 4096
Trace32Log "078 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
WScript.Quit
'*** 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 )
#########################################################################
>>> pckonfiguration-wintuc_fwmgr.vbs <<<
'*** v9.7 *** www.dieseyer.de *******************************
'
' Datei: PC–Konfiguration für WinTuC_FwMgr.vbs
' Datei: PCKonfiguration-WinTuC_FwMgr.vbs
' Autor: xxx.dexter.xxx@googlemail.com
' Auf: www.dieseyer.de / www.wintuc.de
'
' Ursprünglich war vorgesehen, die PC-Konfiguration vor dem
' 'Freischalten' für WinTuC zu speichern, um diese ggf.
' zurück stellen zu können.
' Da für das 'Freischalten' an dem PC sehr wahrscheinlich
' eine lokale Anmeldung mit einem Admin-User erforderlich
' ist, kann man gleich WinTuC vom USB-Stick starten - damit
' ist der einmalige WinTuC-Einsatz erledigt. Und soll WinTuC
' mehrmals eingesetzt werden, ist das zurück setzen auf eine
' ältere Konfiguration nicht erforderlich.
'
' Windows Firewall Reference
' http://msdn.microsoft.com/en-us/libr...52(VS.85).aspx
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const NET_FW_SCOPE_LOCAL_SUBNET = 1 ' Nur eigenes Netzwerk (Subnetz)
Const NET_FW_SERVICE_FILE_AND_PRINT = 0 ' Datei- und Druckerfreigabe
Dim FirewallManager
ON ERROR RESUME NEXT
Set FirewallManager = CreateObject("HNetCfg.FwMgr")
If Err <> 0 Then
WScript.Echo "Windows Firewall kann nicht bestimmt werden!"
WScript.Quit(1)
End If
ON ERROR GOTO 0
'*** Remoteverwaltung aktivieren
'* -----------------------------
'* -> DCE Endpoint Resolution (TCP 135)
'* -> SMB über TCP (TCP 445)
With FirewallManager.LocalPolicy.CurrentProfile.RemoteAdminSettings
If Not .Enabled Then
.Enabled = TRUE
.Scope = NET_FW_SCOPE_LOCAL_SUBNET
End If
End With
'*** Datei- und Druckerfreigabe aktivieren
'* ---------------------------------------
'* -> NetBIOS-Sitzungsdienst (TCP 139)
'* -> SMB über TCP (TCP 445)
'* -> NetBIOS-Namensdienst (UDP 137)
'* -> NetBIOS-Datagrammdienst (UDP 138)
With FirewallManager.LocalPolicy.CurrentProfile.Services.Item(NET_FW_SERVICE_FILE_AND_PRINT)
If Not .Enabled Then
.Enabled = TRUE
.Scope = NET_FW_SCOPE_LOCAL_SUBNET
End If
End with
#########################################################################
>>> pclistetesten.hta <<<
</html>
<head>
<!--
'*** v9.B *** www.dieseyer.de ******************************
'
' Datei: pclistetesten.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'***********************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
ICON="dieseyer.ico"
-->
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="PC Liste testen"
SINGLEINSTANCE="yes"
MAXIMIZEBUTTON="no"
>
<title>PC Liste testen</title>
<style type="text/css">
html, body { background-color: #116; color: #ec0; font-weight: normal; font-size: 9pt; font-family: verdana, arial, sans-serif }
</style>
</head>
<script language="VBscript">
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim arrTst, arrZeilen(), Titel, HtaSelbst, HtaDatum
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AktVerz : AktVerz = fso.GetParentFolderName( HtaSelbst ) ' : MsgBox "AktVerz: " & AktVerz, , "046 :: "
'***********************************************************
Function BeimLaden() ' ruft einige Routinen auf
'***********************************************************
On Error Resume Next
window.moveto 0, 0
On Error Goto 0
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tst
Titel = oHTA.APPLICATIONNAME
HtaSelbst = oHTA.CommandLine
' Auf Vorhandensein der Datei mit IP-Adr. in Array einlesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = AktVerz & "pclistetesten.ini"
If not fso.FileExists( Tst ) Then
MsgBox "Datei mit IP-Adr. fehlt:" & vbCRLF & vbCRLF & Tst, vbCritical, "066 :: " & Titel
Exit Function
End If
' Datei mit IP-Adr. in Array einlesen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrTst = DateiInhalt( Tst )
Tst = "075 :: UBound( arrTst ) = " & UBound( arrTst )
' MsgBox Tst, , "076 :: " ' Anzahl der Zeilen anzeigen
ReDim Preserve arrZeilen( UBound( arrTst ) )
Tst = "080 :: UBound( arrZeilen ) = " & UBound( arrZeilen )
' MsgBox Tst, , "081 :: " ' Anzahl der Zeilen anzeigen
' ArrayZeigen( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Array mit IP-Adr. schnell sortieren - ein 'Quicky'
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
QuickSort arrTst, LBound( arrTst ), UBound( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrTst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' call pclistetesten( 0 )
window.setTimeout "pclistetesten('0')", 3* 333
window.setTimeout "ErgebnZeigen()", 333
' window.setInterval "ErgebnZeigen()", 333
End Function ' BeimLaden()
'***********************************************************
Sub ErgebnZeigen()
'***********************************************************
Dim t, i
t = t & "<table border=""1"" >"
' t = t & "<table border=""1"" width=""100%"">"
t = t & " <colgroup>"
t = t & " <col width=""150"">"
t = t & " <col width=""200"">"
t = t & " <col width=""300"">"
t = t & " <col width=""400"">"
t = t & " <col >"
t = t & " </colgroup>"
For i = LBound( arrTst ) to UBound( arrTst )
t = t & " <tr>"
t = t & " <td><span id=Zeile" & i & "> " & i & " </span></td>"
t = t & " <td>" & arrTst( i ) & "</td>"
t = t & " <td>" & arrTst( i ) & "</td>"
t = t & " <td>" & arrTst( i ) & "</td>"
t = t & " </tr>"
Next
t = t & "</table>"
t = t & "<br>"
' t = t & "<center>"
' t = t & " " & now() & " - " & Timer()
' t = t & " <br>"
' t = t & " <br>"
' t = t & " Neu starten mit [F5]"
' t = t & " <br>"
' t = t & " <br>"
' t = t & "</center>"
t = t & "<center style="" font-size:7Pt; "">"
' t = t & "<a href=""http://dieseyer.de/scr/pclistetesten.hta"" ><b>pclistetesten.hta</b></a>"
t = t & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
t = t & "<a href=""http://dieseyer.de/dse-impressum.html"" > • © 2009 by dieseyer • all rights reserved • </a>"
t = t & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
t = t & "</center>"
On Error Resume Next
document.all.Anzeige.innerHTML = t
On Error Goto 0
End Sub ' ErgebnZeigen()
'***********************************************************
Sub pclistetesten( Nr )
'***********************************************************
' MsgBox "Nr.: '" & Nr & "'" & vbCRLF & arrTst( Nr )
Dim t
If WMIpingOK( arrTst( Nr ) ) Then
t = "<span style=""color:green; font-weight:bold; ""> OK " & Time() & "</span>"
' MsgBox "document.all.Zeile" & Nr & ".innerHTML = " & t
' window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = 'xxx'", 3*333
Else
t = "<span style=""color:fuchsia; font-weight:bold; ""> <strike> OK </strike> " & Time() & "</span>"
' MsgBox "document.all.Zeile" & Nr & ".innerHTML = " & t
' window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = " & t, 3333
' window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = 'xxx'", 3*333
End If
window.setTimeout "document.all.Zeile" & Nr & ".innerHTML = '" & t & "'", 1*333
Nr = Nr + 1 : If Nr > UBound( arrTst ) Then Nr = LBound( arrTst )
window.setTimeout "pclistetesten('" & Nr & "')", 3 * 333
End Sub ' pclistetesten( Nr )
'*** v9.3 *** www.dieseyer.de ******************************
Function WMIpingOK( PCName )
'***********************************************************
' 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 )
'*** 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 )
'*** v10.5 *** www.dieseyer.de ****************************
Function DateiInhalt( DateiX )
'*********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileIn : Set FileIn = fso.OpenTextFile( DateiX, 1 )
Dim Txt, Tst, i
i = 0 : ReDim Preserve Zeile(i) : Zeile(i) = ""
Do While Not ( FileIn.atEndOfStream )
' Tst = Trim( FileIn.Readline )
Tst = FileIn.Readline
' If Len( Tst ) > 2 Then
Txt = Txt & Tst & vbCRLF
ReDim Preserve Zeile(i)
Zeile(i) = Tst
i = i + 1
' End If
Loop
' MsgBox Txt, , "11 :: "
If UBound( Zeile ) < 1 AND Zeile( UBound( Zeile ) ) = "" Then Zeile( UBound( Zeile ) ) = "LEER"
FileIn.Close
Set FileIn = nothing
DateiInhalt = Zeile
End Function ' DateiInhalt( DateiX )
'*** 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 "303 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "304 :: " & Titel
End Function ' ArrayZeigen( InArray )
'**************************************************************
Sub document_onKeyDown
'**************************************************************
' TastTaste = window.event.keyCode
' Trace32Log "312 :: Betätigte Taste: '" & TastTaste & "'", 1
' If TastTaste = 13 Then Call neuesEnde()
End Sub
</script>
<body onLoad="BeimLaden()">
<span id="Anzeige"></span><br>
<!--
<span id="InfoTxt" style="text-align: center; width: 642px; height: 3em; position: absolute; top: 478px; left: 11px; border: 2px solid red; background-color: #00d;"></span>
-->
</body>
</html>
#########################################################################
>>> pcmitdhcp.vbs <<<
'v2.A***************************************************
' File: PCmitDHCP.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' !!! Nur WinNT/2k/XP !!!
'
' Testet, ob ein PC mit oder ohne DHCP arbeitet.
' Wird das Skript im LoginScript aufgerufen, gibt die
' LOG-Datei eine übersicht zu allen PC's.
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
DIM Ziel, Text1, Text2, FileIn
DIM WSHShell, FSO, WSHNet
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Ziel = wshnet.ComputerName & ".tmp"
WshShell.run ("%comspec% /c ipconfig /all > " & Ziel),0,true
Set FileIn = fso.OpenTextFile(Ziel, 1 ) ' Datei zum Lesen öffnen
Text2 = "kein DHCP"
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Text1 = CStr( FileIn.Readline ) ' eine Zeile lesen
if InStr( UCase ( Text1) , "DHCP") then
if InStr( UCase ( Text1) , "JA") then Text2 = "DHCP"
if InStr( UCase ( Text1) , "YES") then Text2 = "DHCP"
End If
Loop
FileIn.Close
Set FileIn = nothing
If Text2 = "DHCP" then LogDatei wshnet.ComputerName & vbTab & "dyn. IP-Adr. / verwendet DHCP"
If not Text2 = "DHCP" then LogDatei wshnet.ComputerName & vbTab & "stat. IP-Adr."
'folgende Zeile freigeben
'*******************************************************
if fso.FileExists(Ziel) Then fso.DeleteFile(Ziel), True ' Datei löschen
wshshell.Popup "PC " & wshnet.ComputerName & " verwendet " & Text2 , 15, WScript.ScriptName
'*********************************
Sub LogDatei (LogTxt)
'*********************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( WScript.ScriptName & ".log", 8, true)
' FileOut.WriteLine (vbCRLF & Now() )
FileOut.WriteLine (now() & vbTab & LogTxt)
FileOut.Close
Set FileOut = Nothing
End Sub ' LogDatei
#########################################################################
>>> permanentpopup.vbs <<<
'*** v5.6 *** www.dieseyer.de *******************************
'
' Datei: permanentpopup.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Eine PopUp-Meldung, die sich nicht weg klicken läßt.
'
'************************************************************
Option Explicit
Dim fso, SkriptName, Text
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wo soll das (Tochter-) Skript ("-aktive.vbs") stehen?
SkriptName = fso.GetBaseName( WScript.ScriptName ) & "-aktive.vbs" ' im Skript-Verzeichnis
SkriptName = fso.GetSpecialFolder( 2 ) & "\-aktive.vbs" ' im User-Abhängigen Temp-Verzeichnis
' MsgBox SkriptName, , "18 :: " & WScript.ScriptName
' was soll das (Tochter-) Skript anzeigen?
Text = "Dies ist eine sehr wichtige Nachricht!"
' das (Tochter-) Skript erzeugen und aufrufen
PermanentPopUp SkriptName, Text ' Function Aufruf
' das Skript hat jetzt viel und wichtiges zu tun - 60s lang
WScript.Sleep 60*1000
' das Skript ist fertig mit: viel und wichtiges zu tun
fso.DeleteFile( SkriptName )
WScript.Sleep 1*1000
MsgBox WScript.ScriptName & " . . . ist zu Ende", , WScript.ScriptName
WScript.Quit
'*** v5.6 *** www.dieseyer.de *******************************
Sub PermanentPopUp( SkriptName, Text )
'*************************************************************
Dim AKTIVvbs
Dim fso, WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set AKTIVvbs = Fso.OpenTextFile( SkriptName , 2, true)
AKTIVvbs.WriteLine "Set WSHShell = WScript.CreateObject(""WScript.Shell"") "
AKTIVvbs.WriteLine "Set fso = WScript.CreateObject(""Scripting.FileSystemObject"") "
AKTIVvbs.WriteLine "Txt = """ & Text & """"
AKTIVvbs.WriteLine "Titel = ""!!! ACHTUNG !!!"" "
AKTIVvbs.WriteLine "Do"
' AKTIVvbs.WriteLine "WshShell.Popup Txt, 2, Titel "
AKTIVvbs.WriteLine "WshShell.Popup Txt, 2, Titel, vbSystemModal "
AKTIVvbs.WriteLine "if not fso.FileExists( WScript.ScriptFullName ) Then Exit Do"
AKTIVvbs.WriteLine "Loop"
AKTIVvbs.WriteLine "WshShell.Popup "". . . das wars"", 3, Titel "
AKTIVvbs.Close
Set AKTIVvbs = Nothing
WSHShell.Run SkriptName
End Sub ' PermanentPopUp( SkriptName, Text )
#########################################################################
>>> popsup.vbs <<<
'v6.2***************************************************
' File: PopsUp.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Function PopsUp ( TxT, Dauer )
' erstellt ein MSG-VBScript im %TEMP%-Verzeichnis und
' ruft es mit WSHShell.Exec auf.
' Dadurch ist es beim Erneuten Aufruf des MSG-VBscripts
' möglich, das "alte" PopUp (vor Zeitablauf) zu beenden.
'*******************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Prog_PP : Set Prog_PP = nothing ' für Function PopsUp ( TxT, Dauer )
Dim i
For i = 1 to 7 Step 2
WScript.Sleep i*500
PopsUp "Hallo - Hallo - Hallo - Hallo - Hallo " & vbTab & i, 20
' eigentlich müsste das PopUp 20s stehen bleiben, wird aber durch
' den erneuten Aufruf vorher geschlossen, bevor ein neues aufgeht
' PopsUp "Hallo" & vbTab & i, 20
Next
PopsUp "Ende - Ende - Ende - Ende - Ende - Ende" , 20
WScript.Sleep 10 * 1000 ' Nach 10s (statt 20) kommt: zum löschen des letzten PopsUp
PopsUp "" , 0 ' zum löschen des letzten PopsUp
WScript.Quit
'*** v9.5 *** www.dieseyer.de *******************************
Function PopsUp ( TxT, Dauer )
'************************************************************
' in VBS und HTA verwendbar
' ACHTUNG! Ausserhalb und vor dem ersten Aufruf dieser Prozedur
' muss einmal "Set Prog_PP = nothing" stehen, sonst wird es
' mit dem "prog.terminate" innerhalb der Prozedur nichts!
'
' ACHTUNG! Alle Variablen müssen ausserhalb dieser Prozedur
' deklariert werden (also folgende Zeilen an den Skript-Anfang):
' Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
' Set Prog_PP = nothing
Dim Fso_PP : Set Fso_PP = CreateObject("Scripting.FileSystemObject")
' VBSDatei_PP = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
Dim VBSDatei_PP : VBSDatei_PP = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
Dim FileOut_PP
On Error Resume Next
Prog_PP.terminate
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
If Txt = "" then
On Error Resume Next
IF Fso_PP.FileExists(VBSDatei_PP) then Fso_PP.DeleteFile(VBSDatei_PP) ' löscht das MSG-VBScript
On Error GoTo 0
Exit Function
End If
Txt = Replace( Txt, vbCRLF, """ & vbCRLF & """ )
Set FileOut_PP = Fso_PP.OpenTextFile(VBSDatei_PP, 2, true) ' MSG-VBScript öffnen mit neu anlegen
FileOut_PP.WriteLine "WScript.CreateObject(""WScript.Shell"").Popup """ & Txt & """ , " & Dauer & ", """ & Fso_PP.GetFileName( VBSDatei_PP ) & " "" , vbSystemModal "
' AKTIVvbs.WriteLine "WshShell.Popup Txt, 2, Titel, vbSystemModal "
FileOut_PP.Close
Set FileOut_PP = Nothing
Set Fso_PP = Nothing
On Error Resume Next
Set Prog_PP = CreateObject("WScript.Shell").exec( "WScript """ & VBSDatei_PP & """" )
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
End Function ' PopsUp ( TxT, Dauer )
#########################################################################
>>> popup-meldung.vbs <<<
'v6.6***********************************************************
' File: popup-meldung.vbs
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'
'
'***************************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WshSysEnv : Set WshSysEnv = WSHShell.Environment("SYSTEM")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim Pfad : Pfad = fso.GetParentFolderName( WScript.ScriptFullName )
Dim Pos, Txt, Tst, i, n, PC, DateiName
Dim FileOut, FileIn
'hole alle Argumente
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Txt = Txt & i & vbTab & oArgs.item(i) & vbCRLF
Next
Txt = Txt & WSHNet.ComputerName & " - " & WSHNet.ComputerName
WSHShell.Popup Txt, 10, WScript.ScriptName
WSCript.Quit
#########################################################################
>>> progr-cpu-last-test.vbs <<<
'*** v6.1 *** www.dieseyer.de *******************************
' File: progr-cpu-last-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' schreibt über 10s drei Werte in eine LOG-Datei:
'
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "Monitor Process Performance"
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, n, Progr
Progr = "C:\Programme\AVPersonal\AVWIN.EXE"
Progr = """C:\Programme\AntiVir PersonalEdition Classic\avcenter.exe"""
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
' LOG-Datei für Protokollierung öffnen
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut : Set FileOut = fso.OpenTextFile( Replace( WSCript.ScriptName, "vbs", "log" ), 2, true)
' WMI bereit stellen
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim objRefresher : Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Dim colItems : Set colItems = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfProc_Process").objectSet
Dim objItem
' zu überwachendes Programm starten
fileOut.WriteLine( now() & vbTab & "Wird gestartet: " & Progr )
WshShell.Run Progr, , False ' nicht aufs Ende des gestarteten Programms warten
fileOut.WriteLine( now() & vbTab & "Läuft : " & Progr )
' ProgrammName, ohne Erweiterung und ohne Pfad
Progr = Replace( Progr, """", "" )
Progr = Mid( Progr, InStrRev( Progr, "\" ) + 1 )
Progr = Left( Progr, InStrRev( Progr, "." ) - 1 )
' MsgBox Progr, , "0043 :: " & WScript.ScriptName : WScript.Quit
' gestartetes Programm überwachen
objRefresher.Refresh
Do
For Each objItem in colItems
If InStr( LCase( objItem.Name ), LCase( Progr ) ) > 0 Then
Txt = Txt & "Handle Count: " & objItem.HandleCount & vbTab
Txt = Txt & "Percent Processor Time: " & objItem.PercentProcessorTime & vbTab
Txt = Txt & "Working Set: " & objItem.WorkingSet & vbTab
fileOut.WriteLine( now() & vbTab & Txt ) : Txt = ""
End If
Next
wscript.sleep( 100 ) : n = n + 1 : If n > 100 Then Exit Do
objRefresher.Refresh
Loop
fileOut.WriteLine( "0062 :: " & now() & vbTab & "Skriptende" )
fileOut.Close
Set FileOut = Nothing ' Datei schließen
'*** v6.1 *** www.dieseyer.de *******************************
Function Now()
'************************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ! ! ! Damit funktioniert natürlich DateDiff nicht mehr ! ! !
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Now gibt jetzt einen String und kein (verwendbares) Datum zurück
Now = Date & " " & Time & ",00"
' Wenn Timer() ein Komma enthält, wird: Now = Date & " " & Time & [Rest von Timer]
If InStr( Timer(), "," ) > 0 Then Now = Date & " " & Time & Mid( Timer(), InStr( Timer(), "," ) )
' Wenn Timer() nach dem Komma einstellig ist, wir eine 0 angehangen
If Len( Mid( Now, InStrRev( Now, "," ) ) ) = 2 Then Now = Now & "0"
End Function ' Now()
#########################################################################
>>> programmauswahl.vbs <<<
'v3.8********************************************************
' File: programmauswahl.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Wechselt zwischen 2 Programmen, von denen immer eines
' gestartet sein soll.
'************************************************************
Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Text, Prog, Prog1, Prog2, ProgExec, MsgIcon
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' erstes Programm festlegen
Prog1 = "C:\Programme\Windows NT\Zubehör\WORDPAD.EXE"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' gibt es das erstes Programm nicht, ein anders festlegen
if not fso.FileExists( Prog1 ) then Prog1 = "C:\Programme\Zubehör\WORDPAD.EXE"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' gibt es das erstes Programm nicht ==> Programmende
if not fso.FileExists( Prog1 ) then
MsgBox Prog1 & vbCRLF & " existiert nicht. Das ist das Ende."
WScript.Quit
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' zweites Programm festlegen
Prog2 = "C:\WINNT\system32\CALC.EXE"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' gibt es das zweite Programm nicht ==> Programmende
if not fso.FileExists( Prog2 ) then
MsgBox Prog2 & vbCRLF & " existiert nicht. Das ist das Ende."
WScript.Quit
End If
Prog = "---"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Text" für die erste Frage zusammenbauen
Text = "Zur Zeit läuft keines der beiden Programme. " & vbCRLF
Text = Text & "Welches soll gestartet werden?" & vbCRLF & vbCRLF
Text = Text & "[ja]" & vbTab & Prog1 & vbCRLF & vbCRLF
Text = Text & "[nein]" & vbTab & Prog2 & vbCRLF
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' erste Frage stellen; Ergebnis steht dann in "Text"
Text = MsgBox( Text, vbYesNoCancel + vbQuestion , WScript.ScriptName)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn "Abbrechen" betätigt wurde
If Text = vbCancel then WScript.Quit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ausgewähltes Programm an Variable "Prog" übergeben
If Text = vbYes then Prog = Prog1
If Text = vbNo then Prog = Prog2
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ausgewähltes Programm starten
Set ProgExec = createObject("WScript.Shell").exec( Prog )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Do .. Loop"-Schleife immer wieder durchlaufen
Do
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 500ms Pause
WScript.Sleep 500
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' In der folgenden Abfrage-"MsgBox" soll je nach bereits
' laufenden Programm ein anderes Icon angezeigt werden
if Prog = Prog1 then MsgIcon = vbExclamation ' Warnung
if Prog = Prog2 then MsgIcon = vbInformation ' Information
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Text" für die folgende Abfrage-"MsgBox" zusammen bauen
Text = "Zuletzt wurde " & vbCRLF & vbCRLF
Text = Text & vbTab & Prog & vbCRLF & vbCRLF
Text = Text & "gestartet - soll jetzt " & vbCRLF & vbCRLF
if Prog = Prog1 then Text = Text & vbTab & Prog2 & vbCRLF & vbCRLF
if Prog = Prog2 then Text = Text & vbTab & Prog1 & vbCRLF & vbCRLF
Text = Text & "gestartet werden? "
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Abfrage-"MsgBox" stellen
Text = MsgBox( Text, vbOKCancel + MsgIcon , fso.GetFileName( Prog ) & " . . . wurde zuletzt gestartet." )
'----------------------------------------------------------------------------------
' Info zu vbOKCancel + MsgIcon
' der zweite Parameter (nach dem ersten Komma) legt fest, welche Schaltflächen
' und welches Bildchen zu sehen ist
'----------------------------------------------------------------------------------
' Info zu fso.GetFileName( Prog ) & " . . . wurde zuletzt gestartet."
' der dritte Parameter (nach dem zweiten Komma) legt den Tietel fest, der im
' oberen (blauen) Fensterbalken und damit unten in der Task-Leiste angezeigt
' wird.
'----------------------------------------------------------------------------------
' Info zu fso.GetFileName( Prog )
' löst den Dateinamen aus dem Dateinamen mit Pfadangabe heraus
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn "Abbrechen" betätigt wurde, "Do .. Loop"-Schleife
' verlassen
If Text = vbCancel then Exit Do
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn "Ok" betätigt wurde
If Text = vbOk then
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Das bereits laufende Programm beenden
ProgExec.terminate
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Text" erhält den "anderen" Programmnamen
if Prog = Prog1 then Text = Prog2
if Prog = Prog2 then Text = Prog1
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "anderes" Programm starten
Set ProgExec = createObject("WScript.Shell").exec( Text )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Prog" merkt sich, welches Programm gerade gestartet wurde
Prog = Text
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' . . . und es geht dort weiter, wo "Do" steht
Loop
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Das laufende Programm beenden
ProgExec.terminate
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Das Skript beenden bzw. verlassen
WScript.Quit
#########################################################################
>>> programmminimieren.vbs <<<
'v5.5***********************************************************
' File: ProgrammMinimieren.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' demonstriert die Verwendung der AppActivate- und der SendKeys-
' Methode. Bei vielen Programmen greift die AppActivate-Methode,
' wenn die ersten Zeichen mit denen in der Programmleiste ange-
' zeigten übereinstimmt. Gibt es mehrere laufende Programme, die
' z.B. mit "C:\" (in der Programmleiste) beginnen, ist wohl
' die Taskreihenfolge entscheidend. Groß- / Kleinschreibung wird
' von der AppActivate-Methode ignoriert.
'***************************************************************
Option Explicit
Dim WshShell, progr
set WshShell = WScript.CreateObject("WScript.Shell")
progr = "Outlook Express"
progr = "Allgemein Ausgang" ' Mixer
progr = "Explorer - C:\" ' im Explorer wird z.B. c:\temp angezeigt
progr = "C:\" ' WinXP: im Explorer wird z.B. c:\temp angezeigt
progr = "freenet.de" ' im IE
if WshShell.AppActivate( progr ) = True Then
WScript.Sleep 333
WshShell.sendkeys "%{ }n"
Else
MsgBox "Kein Programm hat in der Programmleiste" & vbCRLF & "folgende Zeichenkette (von links beginnend):" & vbCRLF & vbCRLF & progr
End If
#########################################################################
>>> programmschliessen.vbs <<<
'v3.C***********************************************************
' File: ProgrammSchliessen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' demonstriert die Verwendung der AppActivate- und der SendKeys-
' Methode. Bei vielen Programmen greift die AppActivate-Methode,
' wenn die ersten Zeichen mit denen in der Programmleiste ange-
' zeigten übereinstimmt. Gibt es mehrere laufende Programme, die
' z.B. mit "explorer" (in der Programmleiste) beginnen, ist wohl
' die Taskreihenfolge entscheidend. Groß- / Kleinschreibung wird
' von der AppActivate-Methode ignoriert.
'***************************************************************
Option Explicit
Dim WshShell, progr
set WshShell = WScript.CreateObject("WScript.Shell")
progr = "Outlook Express"
progr = "Allgemein Ausgang" ' Mixer
progr = "Explorer - C:\" ' im Explorer wird z.B. c:\temp angezeigt
if WshShell.AppActivate( progr ) = True Then
WScript.Sleep 333
WshShell.sendkeys "%{F4}"
Else
MsgBox "Kein Programm hat in der Programmleiste" & vbCRLF & "folgende Zeichenkette (von links beginnend):" & vbCRLF & vbCRLF & progr
End If
#########################################################################
>>> progrs-nacheinander-starten.vbs <<<
'*** v6.1 *** www.dieseyer.de *******************************
'
' File: programme-nacheiander-starten.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Das Skript meldet sich, wenn ein Programm komplett
' geladen ist. Dann soll die CPU-Last über eine "Dauer"
' kleiner 10% Sein.
' siehe dazu auch: progr-cpu-last-test.vbs
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "Monitor Process Performance"
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
ProgrRuheOK "C:\Programme\AVPersonal\AVWIN.EXE", 5 ' ohne LOG-Datei
' ProgrRuheOKlog "C:\Programme\AVPersonal\AVWIN.EXE", 5 ' mit LOG-Datei
MsgBox "Habe fertig . . . ", 4096, WScript.ScriptName
WScript.Quit
'*** v6.1 *** www.dieseyer.de *******************************
Function ProgrRuheOK( Progr, Dauer )
'************************************************************
' CPU-Last durch "Progr" soll für den Zeitraum
' von "Dauer" unter 10% liegen
Const CPUlast = 10
Dim i, Zeit, Tst
' WMI bereit stellen
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim objRefresher : Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Dim colItems : Set colItems = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfProc_Process").objectSet
Dim objItem
' zu überwachendes Programm starten, nicht aufs Ende des gestarteten Programms warten
WScript.CreateObject("WScript.Shell").Run Progr, , False
' ProgrammName, wei er im Taskmanager erscheint
Progr = Mid( Progr, InStrRev( Progr, "\" ) + 1 )
Progr = Left( Progr, InStrRev( Progr, "." ) - 1 )
' MsgBox ProgrTst : WScript.QUIT
Zeit = Timer()
' gestartetes Programm überwachen
Do
wscript.sleep( 100 )
objRefresher.Refresh
For Each objItem in colItems
If InStr( UCase( objItem.Name ), "AVWIN" ) > 0 Then
Tst = objItem.PercentProcessorTime
If Int( Tst ) > CPUlast Then Zeit = Timer()
End If
Next
If Timer() - Zeit > Dauer Then Exit Do
Loop
ProgrRuheOK = True
End Function ' ProgrRuheOK( Progr, Dauer )
'*** v6.1 *** www.dieseyer.de *******************************
Function ProgrRuheOKlog( Progr, Dauer )
'************************************************************
' CPU-Last durch "Progr" soll für den Zeitraum
' von "Dauer" unter 10% liegen
Const CPUlast = 10
Dim i, Zeit, Tst
' LOG-Datei für Protokollierung öffnen
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut : Set FileOut = fso.OpenTextFile( Replace( WSCript.ScriptName, "vbs", "log" ), 2, true)
' WMI bereit stellen
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim objRefresher : Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Dim colItems : Set colItems = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfProc_Process").objectSet
Dim objItem
' zu überwachendes Programm starten, nicht aufs Ende des gestarteten Programms warten
WScript.CreateObject("WScript.Shell").Run Progr, , False
' ProgrammName, wei er im Taskmanager erscheint
Progr = Mid( Progr, InStrRev( Progr, "\" ) + 1 )
Progr = Left( Progr, InStrRev( Progr, "." ) - 1 )
' MsgBox ProgrTst : WScript.QUIT
Zeit = Timer()
' gestartetes Programm überwachen
Do
wscript.sleep( 100 )
objRefresher.Refresh
For Each objItem in colItems
If InStr( UCase( objItem.Name ), "AVWIN" ) > 0 Then
Tst = objItem.PercentProcessorTime
If Int( Tst ) > CPUlast Then Zeit = Timer()
End If
Next
If Timer() - Zeit > Dauer Then Exit Do
fileOut.WriteLine( now() & vbTab & Tst & vbTab & Timer() - Zeit )
Loop
fileOut.WriteLine( now() & vbTab & Tst & vbTab & Timer() - Zeit )
ProgrRuheOKlog = True
End Function ' ProgrRuheOKlog( Progr, Dauer )
'*** v6.1 *** www.dieseyer.de *******************************
Function Now()
'************************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ! ! ! Damit funktioniert natürlich DateDiff nicht mehr ! ! !
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Now gibt jetzt einen String und kein (verwendbares) Datum zurück
Now = Date & " " & Time & ",00"
' Wenn Timer() ein Komma enthält, wird: Now = Date & " " & Time & [Rest von Timer]
If InStr( Timer(), "," ) > 0 Then Now = Date & " " & Time & Mid( Timer(), InStr( Timer(), "," ) )
' Wenn Timer() nach dem Komma einstellig ist, wir eine 0 angehangen
If Len( Mid( Now, InStrRev( Now, "," ) ) ) = 2 Then Now = Now & "0"
End Function ' Now()
#########################################################################
>>> progrs-nacheinander-starten2.vbs <<<
'*** v6.1 *** www.dieseyer.de *******************************
' File: programme-nacheiander-starten2.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Das Skript meldet sich, wenn ein Programm komplett
' geladen ist. Hier (AVWIN.EXE) wird der Umstand aus-
' genutzt, dass das Programm komplett geladen ist, wenn
' der "Handle Count" von 97 auf 95 sinkt - siehe dazu
' auch: progr-cpu-last-test.vbs
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "Monitor Process Performance"
'
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' ProgrRuheCountLog "C:\Programme\AVPersonal\AVWIN.EXE", 97, 95 ' mit LOG-Datei
ProgrRuheCount "C:\Programme\AVPersonal\AVWIN.EXE", 97, 95 ' ohne LOG-Datei
MsgBox "Habe fertig . . . ", 4096, WScript.ScriptName
WScript.Quit
'*** v6.1 *** www.dieseyer.de *******************************
Function ProgrRuheCountLog( Progr, Count1, Count2 )
'************************************************************
' der "Handle Count" für "Progr" sinkt von "Count1" auf
' "Count2", wenn das "Progr" komplett gestarte ist
Dim i, Txt, Tst
' LOG-Datei für Protokollierung öffnen
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim FileOut : Set FileOut = fso.OpenTextFile( Replace( WSCript.ScriptName, "vbs", "log" ), 2, true)
' WMI bereit stellen
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim objRefresher : Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Dim colItems : Set colItems = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfProc_Process").objectSet
Dim objItem
' zu überwachendes Programm starten, nicht aufs Ende des gestarteten Programms warten
WScript.CreateObject("WScript.Shell").Run Progr, , False
' ProgrammName, wei er im Taskmanager erscheint
Progr = Mid( Progr, InStrRev( Progr, "\" ) + 1 )
Progr = Left( Progr, InStrRev( Progr, "." ) - 1 )
' MsgBox ProgrTst : WScript.QUIT
' gestartetes Programm überwachen
Do
wscript.sleep( 100 )
objRefresher.Refresh
For Each objItem in colItems
If InStr( UCase( objItem.Name ), "AVWIN" ) > 0 Then
Tst = Int( objItem.HandleCount )
fileOut.WriteLine( now() & vbTab & Tst & vbTab )
If Int( Tst ) = Count1 Then Txt = Tst
If Int( Tst ) = Count2 And Txt = Count1 Then Exit Do
End If
Next
fileOut.WriteLine( now() & vbTab & Tst )
Loop
fileOut.WriteLine( now() & vbTab & "Skript-Ende")
ProgrRuheCountLog = True
End Function ' ProgrRuheCountLog( Progr, Count1, Count2 )
'*** v6.1 *** www.dieseyer.de *******************************
Function ProgrRuheCount( Progr, Count1, Count2 )
'************************************************************
' der "Handle Count" für "Progr" sinkt von "Count1" auf
' "Count2", wenn das "Progr" komplett gestarte ist
Dim i, Txt, Tst
' LOG-Datei für Protokollierung öffnen
' WMI bereit stellen
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim objRefresher : Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Dim colItems : Set colItems = objRefresher.AddEnum (objWMIService, "Win32_PerfFormattedData_PerfProc_Process").objectSet
Dim objItem
' zu überwachendes Programm starten, nicht aufs Ende des gestarteten Programms warten
WScript.CreateObject("WScript.Shell").Run Progr, , False
' ProgrammName, wei er im Taskmanager erscheint
Progr = Mid( Progr, InStrRev( Progr, "\" ) + 1 )
Progr = Left( Progr, InStrRev( Progr, "." ) - 1 )
' MsgBox ProgrTst : WScript.QUIT
' gestartetes Programm überwachen
Do
wscript.sleep( 100 )
objRefresher.Refresh
For Each objItem in colItems
If InStr( UCase( objItem.Name ), "AVWIN" ) > 0 Then
Tst = Int( objItem.HandleCount )
If Int( Tst ) = Count1 Then Txt = Tst
If Int( Tst ) = Count2 And Txt = Count1 Then Exit Do
End If
Next
Loop
ProgrRuheCount = True
End Function ' ProgrRuheCount( Progr, Count1, Count2 )
'*** v6.1 *** www.dieseyer.de *******************************
Function Now()
'************************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ! ! ! Damit funktioniert natürlich DateDiff nicht mehr ! ! !
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Now gibt jetzt einen String und kein (verwendbares) Datum zurück
Now = Date & " " & Time & ",00"
' Wenn Timer() ein Komma enthält, wird: Now = Date & " " & Time & [Rest von Timer]
If InStr( Timer(), "," ) > 0 Then Now = Date & " " & Time & Mid( Timer(), InStr( Timer(), "," ) )
' Wenn Timer() nach dem Komma einstellig ist, wir eine 0 angehangen
If Len( Mid( Now, InStrRev( Now, "," ) ) ) = 2 Then Now = Now & "0"
End Function ' Now()
#########################################################################
>>> prozedurintxt.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: ProzedurInTxt.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Übergibt (aus dem aktuellen VBS) den Inhalt einer Prozedur,
' um einfach aus Skripten heraus Skripte mit Sub- oder
' Function-Prozeduren zu erstellen - die 'spielereien' mit
' den Anführungszeichen übernimmt dabei das Skript.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox ProzedurInTxt( "SinnLOS" )
WScript.Quit
Function SinnLos( XXX )
MsgBox "Ist das nicht sinnlos?!"
End Function ' SinnLos( XXX )
'*** v8.4 *** www.dieseyer.de ****************************
Function ProzedurInTxt( ProzName )
'*********************************************************
' Übergibt (aus dem aktuellen VBS) den Inhalt einer Prozedur
ProzName = LCase( ProzName )
Dim i
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, ZeileAkt, ProzOK
ProzOK = "-OK"
Txt = "'*********************************************************"
Dim FileIn : Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
ZeileAkt = FileIn.Readline
Tst = LCase( ZeileAkt )
If ProzOK = "-OK" Then
Tyt = InStr( Tst, "function " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
Tyt = InStr( Tst, "sub " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
End If
If ProzOK = "OK" Then Txt = Txt & vbCRLF & ZeileAkt ' : MsgBox now() & vbCRLF & Txt, , "50 :: " : i = i + 1 : If i > 10 Then WScript.Quit
If ProzOK = "OK" AND InStr( Tst, "end function" ) > 0 Then Exit Do
If ProzOK = "OK" AND InStr( Tst, "end sub" ) > 0 Then Exit Do
Loop
FileIn.Close : Set FileIn = nothing
Txt = Txt & vbCRLF & "'*********************************************************"
ProzedurInTxt = Txt ' : MsgBox now() & vbCRLF & ProzedurInTxt, , "61 :: "
End Function ' ProzedurInTxt( ProzName )
#########################################################################
>>> ramnutzung.vbs <<<
'*** v9.B *** www.dieseyer.de ******************************
'
' Datei: ramnutzung.vbs
' Autor: dieseyer@gmx.de
'
' Zeigt die aktuelle Arbeitsspeicher-Nutzung:
' RAM- (realer Arbeitsspeicher) und
' virtueller Arbeitsspeicher (inkl. Auslagerungsdatei)
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim PC : PC ="."
MsgBox SpeicherNutzung( PC ), , "15 :: " & WScript.ScriptName
WScript.Quit
'*** v9.B *** www.dieseyer.de ******************************
Function SpeicherNutzung( PC )
'***********************************************************
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
' RAM - realer Arbeitsspeicher
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_OperatingSystem", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
Dim objItem, MemFrei, MemTotal, t
MemFrei = 0 : MemTotal = 0
For Each objItem In colItems ' in kBytes
MemFrei = FormatNumber( objItem.FreePhysicalMemory / 1024*10, 0, 0, 0, -2 ) / 10
MemFrei = FormatNumber( objItem.FreePhysicalMemory / 1024 , 0, 0, 0, -2 )
MemFrei = FormatNumber( Round( objItem.FreePhysicalMemory / 1024 ), 0, 0, 0, -2 )
t = t & vbCRLF & "FreePhysicalMemory: " & MemFrei & "MB"
MemTotal = FormatNumber( objItem.TotalVisibleMemorySize / 1024*10, 0, 0, 0, -2 ) / 10
MemTotal = FormatNumber( objItem.TotalVisibleMemorySize / 1024 , 0, 0, 0, -2 )
MemTotal = FormatNumber( Round( objItem.TotalVisibleMemorySize / 1024 ), 0, 0, 0, -2 )
t = t & vbCRLF & "TotalVisibleMemorySize: " & MemTotal & "MB"
Next
SpeicherNutzung = "RAM: " & MemFrei & "MB (" & Round( MemFrei / MemTotal * 100 ) & "%) von " & MemTotal & "MB frei; "
' MsgBox SpeicherNutzung, , "44 :: "
' virtueller Arbeitsspeicher (inkl. Auslagerungsdatei)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim VirtTotal, VirtAkt, VirtFrei
VirtTotal = 0 : VirtAkt = 0 : VirtFrei = 0
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PageFileSetting", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
For Each objItem In colItems
VirtTotal = VirtTotal + objItem.MaximumSize
Next
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PageFileUsage", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
For Each objItem In colItems
VirtAkt = VirtAkt + objItem.CurrentUsage
Next
VirtFrei = VirtTotal - VirtAkt
SpeicherNutzung = SpeicherNutzung & "Virt.: " & VirtFrei & "MB (" & Round( VirtFrei / VirtTotal * 100 ) & "%) von " & VirtTotal & "MB frei."
' MsgBox SpeicherNutzung, , "61 :: "
End Function ' SpeicherNutzung( PC )
#########################################################################
>>> regkey.vbs <<<
' regkey.vbs
' http://msdn.microsoft.com/archive/en-us/dnarwsh/html/wsh_object.asp
'
' Windows Script Host Sample Script
'
' ---------------------------------------------------------------------
' Copyright (C) 1996-1997 Microsoft Corporation
'
' You have a royalty-free right to use, modify, reproduce and distribute
' the Sample Application Files (and/or any modified version) in any way
' you find useful, provided that you agree that Microsoft has no warranty,
' obligations or liability for any Sample Application Files.
' ---------------------------------------------------------------------
'
' This sample demonstrates how to write/delete entries in the registry.
L_Welcome_MsgBox_Message_Text = "This script demonstrates how to create and delete registry keys."
L_Welcome_MsgBox_Title_Text = "Windows Script Host Sample"
Call Welcome()
' **********************************************************************
' *
' * Registry related methods.
' *
Dim WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
WSHShell.Popup "Create key HKCU\MyRegKey with value 'Top level key'"
WSHShell.RegWrite "HKCU\MyRegKey\", "Top level key"
WSHShell.Popup "Create key HKCU\MyRegKey\Entry with value 'Second level key'"
WSHShell.RegWrite "HKCU\MyRegKey\Entry\", "Second level key"
WSHShell.Popup "Set value HKCU\MyRegKey\Value to REG_SZ 1"
WSHShell.RegWrite "HKCU\MyRegKey\Value", 1
WSHShell.Popup "Set value HKCU\MyRegKey\Entry to REG_DWORD 2"
WSHShell.RegWrite "HKCU\MyRegKey\Entry", 2, "REG_DWORD"
WSHShell.Popup "Set value HKCU\MyRegKey\Entry\Value1 to REG_BINARY 3"
WSHShell.RegWrite "HKCU\MyRegKey\Entry\Value1", 3, "REG_BINARY"
WSHShell.Popup "Delete value HKCU\MyRegKey\Entry\Value1"
WSHShell.RegDelete "HKCU\MyRegKey\Entry\Value1"
WSHShell.Popup "Delete key HKCU\MyRegKey\Entry"
WSHShell.RegDelete "HKCU\MyRegKey\Entry\"
WSHShell.Popup "Delete key HKCU\MyRegKey"
WSHShell.RegDelete "HKCU\MyRegKey\"
' ***********************************************************************
' *
' * Welcome
' *
Sub Welcome()
Dim intDoIt
intDoIt = MsgBox(L_Welcome_MsgBox_Message_Text, _
vbOKCancel + vbInformation, _
L_Welcome_MsgBox_Title_Text )
If intDoIt = vbCancel Then
WScript.Quit
End If
End Sub
#########################################################################
>>> remoteccmshare.vbs <<<
'*** v10.3 *** www.dieseyer.de *****************************
'
' Datei: remoteccmshare.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim PC, CacheLocation
PC = "PC1"
CacheLocation = SMSCacheLocation( PC )
MsgBox RemoteCCMShare( PC, CacheLocation ), , "017 :: " & PC
Wscript.Quit
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteCCMShare( PCName, CCMCacheVerz )
'***********************************************************
' Erweiterte "Function RemoteSystemDrive( PCName )""
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WinDir
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteCCMShare = "Fehler: \..\c$: " & Tst : Exit Function
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
WinDir = objOperatingSystem.WindowsDirectory
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
If not InStr( CCMCacheVerz, WinDir ) = 1 Then
RemoteCCMShare = "Fehler: " & CCMCacheVerz & " befindet sich nicht im %windir%-Verzeichnis" : Exit Function
Exit Function
End If
' MsgBox "WinDir: " & WinDir, , "049 :: " & PCName & " " & WScript.ScriptName
RemoteCCMShare = "\\" & PCName & "\" & Left( CCMCacheVerz, 1 ) & "$" & Mid( CCMCacheVerz, 3 )
' MsgBox "RemoteCCMShare: " & RemoteCCMShare, , "052 :: " & PCName & " " & WScript.ScriptName
Tst = LCase( RemoteCCMShare )
Tst = Replace( Tst, "\System32\", "\SysWOW64\" )
Tst = Replace( Tst, "\system32\", "\SysWOW64\" )
Tst = Replace( Tst, "\SYSTEM32\", "\SysWOW64\" )
If fso.FolderExists( Tst ) Then RemoteCCMShare = Tst
' MsgBox "RemoteCCMShare: " & RemoteCCMShare, , "060 :: " & PCName & " " & WScript.ScriptName
If not fso.FolderExists( RemoteCCMShare ) Then
RemoteCCMShare = "Fehler - Nicht erreichbar: " & RemoteCCMShare
' MsgBox "RemoteCCMShare: " & RemoteCCMShare, , "064 :: " & PCName & " " & WScript.ScriptName
Exit Function
End If
' MsgBox "RemoteCCMShare: " & RemoteCCMShare, , "068 :: " & PCName & " " & WScript.ScriptName
RemoteCCMShare = "Erreichbar: " & RemoteCCMShare
End Function ' RemoteCCMShare( PCName, CCMCacheVerz )
'*** v10.3 *** www.dieseyer.de *****************************
Function SMSCacheLocation( PC )
'***********************************************************
Dim objWMIService : Set objWMIService = GetObject("winmgmts://" & PC & "/root/ccm/SoftMgmtAgent")
Dim colItems : Set colItems = objWMIService.ExecQuery("Select * from CacheConfig")
Dim objItem, errTst, Tst
On Error Resume Next
For Each objItem in colItems
errTst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
SMSCacheLocation = "Fehler: 'CacheConfig' nicht ansprechbar: " & errTst
Exit Function
End If
Tst = 0
On Error Resume Next
Tst = objItem.Size
errTst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
SMSCacheLocation = "Fehler: 'objItem.Size' nicht auslesbar: " & errTst
Exit Function
End If
SMSCacheLocation = objItem.Location
Next
Set objWMIService = nothing
Set colItems = nothing
End Function ' SMSCacheLocation( PC )
#########################################################################
>>> remotesysdriveshare.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: remotesysdriveshare.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox RemoteSysDriveShare( "PC02" )
Wscript.Quit
'*** v9.3 *** www.dieseyer.de ******************************
Function RemoteSysDriveShare( PCName )
'***********************************************************
' Erweiterte "Function RemoteSystemDrive( PCName )""
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Lw
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSysDriveShare = "Fehler: \..\c$: " & Tst : Exit Function
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
Lw = objOperatingSystem.SystemDrive
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
Lw = Replace( Lw, ":", "")
' MsgBox "Lw: " & Lw, , "41 :: " & PCName & " " & WScript.ScriptName
RemoteSysDriveShare = "\\" & PCName & "\" & Lw & "$"
' MsgBox "RemoteSysDriveShare: " & RemoteSysDriveShare, , "44 :: " & PCName & " " & WScript.ScriptName
If fso.FolderExists( RemoteSysDriveShare ) Then
RemoteSysDriveShare = "Erreichbar: " & RemoteSysDriveShare
' MsgBox "RemoteSysDriveShare: " & RemoteSysDriveShare, , "48 :: " & PCName & " " & WScript.ScriptName
Exit Function
End If
RemoteSysDriveShare = "Fehler - Nicht erreichbar: " & RemoteSysDriveShare
' MsgBox "RemoteSysDriveShare: " & RemoteSysDriveShare, , "53 :: " & PCName & " " & WScript.ScriptName
End Function ' RemoteSysDriveShare( PCName )
#########################################################################
>>> remotesysrootshare.vbs <<<
'*** v10.3 *** www.dieseyer.de *****************************
'
' Datei: remotesysrootshare.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox RemoteSysRootShare( "PC1" )
Wscript.Quit
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteSysRootShare( PCName )
'***********************************************************
' Erweiterte "Function RemoteSystemDrive( PCName )""
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WinDir
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSysRootShare = "Fehler: \..\c$: " & Tst : Exit Function
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
WinDir = objOperatingSystem.WindowsDirectory
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
WinDir = Replace( WinDir, ":", "")
' MsgBox "WinDir: " & WinDir, , "41 :: " & PCName & " " & WScript.ScriptName
Tst = Left( WinDir, 1 )
RemoteSysRootShare = "\\" & PCName & "\" & Left( WinDir, 1 ) & "$" & Mid( WinDir, 2 )
' MsgBox "RemoteSysRootShare: " & RemoteSysRootShare, , "44 :: " & PCName & " " & WScript.ScriptName
If fso.FolderExists( RemoteSysRootShare ) Then
RemoteSysRootShare = "Erreichbar: " & RemoteSysRootShare
' MsgBox "RemoteSysRootShare: " & RemoteSysRootShare, , "48 :: " & PCName & " " & WScript.ScriptName
Exit Function
End If
RemoteSysRootShare = "Fehler - Nicht erreichbar: " & RemoteSysRootShare
' MsgBox "RemoteSysRootShare: " & RemoteSysRootShare, , "53 :: " & PCName & " " & WScript.ScriptName
End Function ' RemoteSysRootShare( PCName )
#########################################################################
>>> remotesystemdrive.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: remotesystemdrive.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox RemoteSystemDrive( "PC01" )
Wscript.Quit
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteSystemDrive( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %SystemDrive%; häufig C:
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLw " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLwOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLwDr " & Tst : Exit Function
RemoteSystemDrive = objOperatingSystem.SystemDrive
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
' RemoteSystemDrive = "%systemdrive%: " & RemoteSystemDrive
End Function ' RemoteSystemDrive( PCName )
#########################################################################
>>> remotewindir.vbs <<<
'*** v10.3 *** www.dieseyer.de *****************************
'
' Datei: remotewindir.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
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 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
Trace32Log "033 :: RemoteWinDir: " & RemoteWinDir( WSHNet.ComputerName ), 1
WSHShell.Popup "= = = E N D E = = =", 2, "056 :: " & WScript.ScriptName
Trace32Log "057 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteWinDir( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %WINDIR% == %SYSTEMROOT%; häufig C:\Windows
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
Dim WindowsDirectory, SystemDirectory
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-Sys " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysDir " & Tst : Exit Function
WindowsDirectory = objOperatingSystem.WindowsDirectory
SystemDirectory = objOperatingSystem.SystemDirectory
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
If WindowsDirectory = "" Then
SystemDirectory = UCase( SystemDirectory )
If InStr( SystemDirectory, "\SYSTEM32" ) Then WindowsDirectory = Replace( SystemDirectory, "\SYSTEM32", "" )
End If
RemoteWinDir = WindowsDirectory
' RemoteWinDir = "%..root%: " & RemoteWinDir
End Function ' RemoteWinDir( PCName )
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "256 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "257 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
#########################################################################
>>> remotewinversion.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: remotewinversion.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
' und formatiert die Ifirmationen für WiTuC.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox WMIWinVer( WScript.CreateObject("WScript.Network").ComputerName ), , "14 :: " & WScript.ScriptName
' MsgBox WMIWinVer( "PC04" ), , "15 :: " & WScript.ScriptName
Wscript.Quit
'*** v9.2 *** www.dieseyer.de ******************************
Function WMIDateStringToDateYear2(dtmDate) ' zweistellige Jahreszahl, ohne Sekunden
'***********************************************************
WMIDateStringToDateYear2 = CDate(Mid(dtmDate, 7, 2) & "." & Mid(dtmDate, 5, 2) & "." & Left(dtmDate, 4) & " " & Mid (dtmDate, 9, 2) & ":" & Mid(dtmDate, 11, 2) & ":" & Mid(dtmDate,13, 2) )
WMIDateStringToDateYear2 = Replace( WMIDateStringToDateYear2, Year( WMIDateStringToDateYear2 ), Mid( Year( WMIDateStringToDateYear2 ), 3, 2 ) )
WMIDateStringToDateYear2 = Mid( WMIDateStringToDateYear2, 1, InStrRev( WMIDateStringToDateYear2, ":" ) - 1 )
End Function ' WMIDateStringToDateYear2(dtmDate)
'*** v9.3 *** www.dieseyer.de ******************************
Function WMIWinVer( PC )
'***********************************************************
Dim Txt
Dim objWMIService
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Txt = err.Number & " - " & err.Description
On Error Goto 0
If Len( Txt ) > 4 Then : WMIWinVer = "Fehler: WMI-OS. " & Txt : Exit Function
Txt = ""
Dim colOSes : Set colOSes = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Dim objOS
For Each objOS in colOSes
' Txt = Txt & vbCRLF & "Computer Name: " & objOS.CSName
' Txt = Txt & vbCRLF & "Caption: " & objOS.Caption 'Name
Txt = TxT & objOS.Caption
' Txt = Txt & vbCRLF & "Service Pack: " & objOS.ServicePackMajorVersion & "." & objOS.ServicePackMinorVersion
Txt = TxT & " Sp" & objOS.ServicePackMajorVersion
' Txt = Txt & vbCRLF & "Version: " & objOS.Version 'Version & build
' Txt = TxT & " (Build " & objOS.Version & ")"
Txt = TxT & "; installiert am " & WMIDateStringToDateYear2( objOS.InstallDate )
' Txt = Txt & vbCRLF & "Build Number: " & objOS.BuildNumber 'Build
' Txt = Txt & vbCRLF & "Build Type: " & objOS.BuildType
' Txt = Txt & vbCRLF & "OS Type: " & objOS.OSType
' Txt = Txt & vbCRLF & "Other Type Description: " & objOS.OtherTypeDescription
Next
' MsgBox PC & vbCRLF & vbCRLF & ">" & Txt & "<", , "62 :: "
Txt = Replace( Txt, "Edition", "" )
Txt = Replace( Txt, "(R)", "" )
Txt = Replace( Txt, "Microsoft", "" )
Txt = Replace( Txt, "Windows", "Win" )
Txt = Replace( Txt, "Professional", "Prof." )
Txt = Replace( Txt, " ", " " )
WMIWinVer = Txt
End Function ' WMIWinVer( PC )
#########################################################################
>>> restzeit.hta <<<
<html>
<head>
<!--
'v7.A***************************************************
' File: restzeit.hta
' aus countdown-programmstart.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'*******************************************************
-->
<title>Restzeit - Anzeige</title>
<HTA:APPLICATION
ID="HtaID"
APPLICATIONNAME = "CountDown"
SCROLL = "no"
NAVIGABLE = "no"
MAXIMIZEBUTTON = "yes"
MINIMIZEBUTTON = "yes"
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:11pt; 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>
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const vKeyPath = "SOFTWARE\dieseyer.de\Enviroment"
Const vKeyEnde = "RestZeit.hta_ZeitEnde"
Const vKeyDauer = "RestZeit.hta_ZeitDauer"
Const HKLM = &H80000002
Const ProgrName = "\Media\Windows XP-Hardwarefehler.wav"
Dim vZeitDauer
Dim vZeitStart
' vZeitStart = CDate( now() + CDate( "01:01:00" ) )
' vZeitStart = CDate( now() + CDate( "00:05:43" ) )
Dim vAnzeigeNeu, vTitelTxt
Dim vTastTaste, vZeitRest
Dim vAktAnz : vAktAnz = "Frage"
Dim Tst, Txt, Anwendung, i
Dim MsgPop : MsgPop = "5"
Dim vRestTxt
'**************************************************************
Sub AnzeigeNeu( vMitTest )
'**************************************************************
' Aufruf durch: vAnzeigeNeu = window.setInterval("AnzeigeNeu()", 50, "VBScript")
Dim Txt, Tst, Ttt
' aus vZeitStart die Sekunden auf ":00" setzen
vZeitStart = FormatDateTime( vZeitStart, vbShortDate ) & " " & FormatDateTime( vZeitStart, vbShortTime )
' aktuelle Restzeit errechnen; für Tests und Vergleiche
Tst = FormatDateTime( CDate( CDate( vZeitStart ) + CDate( vZeitDauer) - now() ) , vbLongTime ) ' : MsgBox Tst, , "083 :: "
' Anzeige wird nur Aktualisiert, wenn sich die Sekunden geändert haben
' If Tst = vZeitRest Then MsgBox "Exit Sub", , "086 :: "
If Tst = vZeitRest Then Exit Sub
' neue RestZeit setzen / merken
vZeitRest = Tst
Tst = DateDiff( "s", CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ), now() )
' MsgBox Tst & vbCRLF & FormatNumber( Tst, 0, 0, 0, -2 ) , , "092 :: "
' Tst = FormatNumber( Tst, 0, 0, 0, -2 ) ' FormatNumber(Ausdruck[, AnzDezimalstellen[, FührendeNull[, KlammernFürNegativeWerte[, ZiffernGruppieren]]]])
On error Resume Next
Tst = CDbl( Tst )
Txt = err.Number & " - " & err.Description
On Error Goto 0
If Len( Txt ) > 4 Then MsgBox "vZeitStart: " & vZeitStart & vbCRLF & "vZeitRest: " & vZeitRest & vbCRLF & Tst, , "098 :: "
' Restzeit ist zu klein oder gerade abgelaufen
Tst = DateDiff( "s", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) )
If Tst < 3 Then
' bei zu kleiner Restzeit soll das HTA geschlossen werden (nicht beim HTA-Start / 1.HTA-Durchlauf)
MsgBox Tst, , "104 :: "
If vMitTest = True Then
Call window_onbeforeunload
Exit Sub
End If
End If
' vZeitRest zur Anzeige anpassen
Ttt = ""
Tst = DateDiff( "d", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) )
If Tst > 0 Then
Ttt = DateDiff( "d", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) & "d "
' MsgBox ">0", , "114 :: "
End If
Ttt = Ttt & CDate( DateDiff( "s", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) / 24 / 60 / 60 )
If InStr( "x" & vZeitRest, "x00:" ) > 0 Then Ttt = Replace( "x" & vZeitRest, "x00:", "" ) & " min"
' Tst = DateDiff( "s", CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ), now() )
Tst = DateDiff( "s", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) )
' MsgBox Tst & vbCRLF & Ttt & vbCRLF & vZeitRest, , "120 :: "
' Restzeit ist negativ - dürfte nur beim Neustart mit alten Werten aus Registry vorkommen
If Tst < 0 Then
Txt = ""
' Txt = Txt & "<br>vZeitStart: " & vZeitStart & "<br> vZeitDauer: " & vZeitDauer
' Txt = Txt & "<br>vZeitRest: " & vZeitRest & "<br> Tst: " & Tst
' Txt = Txt & "<br>CDate( ""s"", Now() ::: ) = " & DateDiff( "s", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) )
' Txt = Txt & "<br>CDate( " & vZeitStart & ") + CDate( " & vZeitDauer & " ) = " & CDate( vZeitStart ) + CDate( vZeitDauer)
' Txt = Txt & "<br>" & "129 :: <br>"
' Txt = ""
Txt = Txt & "<Span style=""font-size:36pt;font-weight:bold;"">"
Txt = Txt & "Restzeit: " & "abgelaufen "
Txt = Txt & "</Span>"
document.all.idStartRest.innerHTML = Txt
vTitelTxt = "Restzeit ist abgelaufen!"
top.document.title = vTitelTxt & " " & "136 :: "
' Exit Sub
End If
' für unterschiedliche Anzeigeformate
If Tst > 50 Then
Txt = ""
Txt = Txt & "<Span style=""font-size:36pt;font-weight:bold;"">"
Txt = Txt & "Restzeit: " & Ttt
Txt = Txt & "</Span>"
document.all.idStartRest.innerHTML = Txt
vTitelTxt = Ttt & " noch."
top.document.title = vTitelTxt
Else
Txt = ""
Txt = Txt & "<Span style=""font-size:36pt;font-weight:bold;"">"
Txt = Txt & "Restzeit: " & Tst & " sec"
Txt = Txt & "</Span>"
document.all.idStartRest.innerHTML = Txt
vTitelTxt = Tst & "s noch."
top.document.title = vTitelTxt
End If
If vZeitDauer = CDate( "00:00:00" ) Then
vRestTxt = ""
vRestTxt = vRestTxt & "<div align=""center"" >Für das Ende der 'Restzeit' ist <b>"
Txt = FormatDateTime( now() , vbShortDate )
vRestTxt = vRestTxt & Replace( vZeitStart, Txt, "" ) ' wenn das Endezeitpunkt am selben Tag ist, wird das Datum nicht angezeigt
vRestTxt = vRestTxt & "</b> gesetzt.</div>"
Else
vRestTxt = ""
vRestTxt = vRestTxt & "<div align=""center"" >Für das Ende der 'Restzeit' ist <b>"
vRestTxt = vRestTxt & vZeitDauer & " nach "
Txt = FormatDateTime( now() , vbShortDate )
vRestTxt = vRestTxt & Replace( vZeitStart, Txt, "" ) ' wenn das Endezeitpunkt am selben Tag ist, wird das Datum nicht angezeigt
vRestTxt = vRestTxt & "</b> gesetzt, also "
vRestTxt = vRestTxt & Replace( CDate( CDate( vZeitStart ) + CDate( vZeitDauer ) ), Txt, "" )
vRestTxt = vRestTxt & "."
vRestTxt = vRestTxt & "</div>"
End If
Txt = vRestTxt & "<br>"
Tst = DateDiff( "s", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) : Txt = Txt & "Restzeit in Sekunden: " & Tst & "<br>"
Tst = DateDiff( "n", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) : Txt = Txt & "Restzeit in Minuten: " & Tst & "<br>"
Tst = DateDiff( "h", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) : Txt = Txt & "Restzeit in Stunden: " & Tst & "<br>"
Tst = DateDiff( "d", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) : Txt = Txt & "Restzeit in Tagen: " & Tst & "<br>"
Tst = DateDiff( "m", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) : Txt = Txt & "Restzeit in Monaten: " & Tst & "<br>"
Tst = DateDiff( "yyyy", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) : Txt = Txt & "Restzeit in Jahren: " & Tst & "<br>"
document.all.idStartZeit.innerHTML = Txt
' In der letzten Stunde vor Ablauf wird diese HTA in den Vordergrund geholt - zur Erinnerung
' ~~~~~~~~~~~~~~~~~~~~~
' 60min, 30min, 21min, 10min und 5min vor Ablauf
Ttt = "-OK"
Tst = Fix( DateDiff( "n", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) )
If MsgPop = "5" AND Tst < 61 Then MsgPop = "4" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "4" AND Tst < 31 Then MsgPop = "3" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "3" AND Tst < 21 Then MsgPop = "2" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "2" AND Tst < 11 Then MsgPop = "1" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If MsgPop = "1" AND Tst < 6 Then MsgPop = "0" : Ttt = "OK" ' : Tst = MsgPop & " - " & Tst & " - " & Ttt
If Fix( DateDiff( "s", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) ) ) < 30 Then Ttt = "OK" ' die letzten Sekunden
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 window.setTimeout "HtaInVordergrund('" & vTitelTxt & "')", 333
End Sub ' AnzeigeNeu( vMitTest )
'**************************************************************
Sub HtaInVordergrund( vTitel )
'**************************************************************
' 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 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( """ & vTitel & """ )"
FileOut.WriteLine "WScript.Sleep 222"
FileOut.WriteLine "Tst = CreateObject(""WScript.Shell"").AppActivate( """ & vTitel & """ )"
FileOut.WriteLine "WScript.Sleep 111"
FileOut.WriteLine "CreateObject(""WScript.Shell"").SendKeys""% x"""
FileOut.WriteLine "WScript.Sleep 222"
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 111"
' FileOut.WriteLine "WScript.Sleep 1000"
' FileOut.WriteLine "MsgBox Tst & "" - E N D E - "", , WScript.ScriptName"
FileOut.Close
Set FileOut = nothing
window.setTimeout "ProgrRun('" & Datei & "')", 111 ' warten bis VBS 'richtig' geschrieben ist
' MsgBox vbTab & "Datei: " & vbCRLF & Datei, , "238 :: "
End Sub ' HtaInVordergrund( vTitel )
'**************************************************************
Sub ProgrRun( DateiX )
'**************************************************************
CreateObject("WScript.Shell").Run """" & DateiX & """" ', , True
window.setTimeout "Window_OnLoad()", 111 ' warten bis window.clearInterval 'richtig' wirkt
End Sub ' ProgrRun( DateiX )
'**************************************************************
Sub window_onbeforeunload
'**************************************************************
' window.event.returnValue = "> > > > > Diese Anwendung wird beendet! < < < < <"
Dim Txt
' sollte [F5] gedrückt worden sein; [F5] beendet das HTA und lädt es neu
If vTastTaste = 116 Then
Call RegKeySchreiben( vKeyEnde, vZeitStart )
Call RegKeySchreiben( vKeyDauer, vZeitDauer )
Exit Sub
End If
' Sound abspielen
Txt = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%WinDir%") & "\" & ProgrName
If CreateObject( "Scripting.FileSystemObject" ).FileExists( Txt ) Then
' CreateObject("WScript.Shell").Run """C:\Programme\Windows Media Player\wmplayer.exe"" """ & Txt & """", 7, True
' CreateObject("WScript.Shell").Run """" & Txt & """", 7, True
' CreateObject("WScript.Shell").Run """" & Txt & """", 7
End If
Txt = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\restzeit.rtf"
' .RTF-Datei zur Anzeige erstellen
Dim FileOut : Set FileOut = CreateObject("Scripting.FileSystemObject").CreateTextFile( Txt, true )
FileOut.WriteLine "{\rtf1\ansi\deff0{\fonttbl{\f0\fswiss\fcharset0 Arial;}}"
FileOut.WriteLine "{\*\generator Msftedit 5.41.15.1507;}\viewkind4\uc1\pard\lang1031\f0\fs56"
FileOut.WriteLine "! ! ! Die Zeit ist um ! ! !\par"
FileOut.WriteLine "\par"
FileOut.WriteLine "vZeitStart >>>" & vZeitStart & "<<<\par"
FileOut.WriteLine "vZeitDauer >>>" & vZeitDauer & "<<<\par"
FileOut.WriteLine "\par"
FileOut.WriteLine "! ! ! Die Zeit ist um ! ! !\par"
FileOut.WriteLine "}"
FileOut.Close
Set FileOut = nothing
CreateObject("WScript.Shell").Run "wordpad """ & Txt & """"
Self.close
Window.close
End Sub ' window_onbeforeunload
'**************************************************************
Sub RegKeySchreiben( vKey, vWert )
'**************************************************************
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
' MsgBox "Sub RegKeySchreiben( " & vKey & ", " & vWert & " )", , "299 :: "
' Inhalt schreiben
oReg.CreateKey HKLM, vKeyPath
oReg.SetStringValue HKLM, vKeyPath, vKey, CStr( vWert )
End Sub ' RegKeySchreiben( Wert )
'**************************************************************
Function RegKeyLesen( vKey )
'**************************************************************
Dim vKeyInh
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
' Inhalt lesen
oReg.GetExpandedStringValue HKLM, vKeyPath, vKey, vKeyInh
RegKeyLesen = vKeyInh
End Function ' RegKeyLesen
'**************************************************************
Sub Window_OnLoad
'**************************************************************
Dim Tst
' window.moveto Links, Oben ' Position
window.moveto 150, 150
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 820, 600
Tst = "" : Tst = RegKeyLesen( vKeyEnde ) : If not Tst = "" Then vZeitStart = Tst
Tst = "" : Tst = RegKeyLesen( vKeyDauer ) : If not Tst = "" Then vZeitDauer = Tst
If vZeitDauer = "" Then vZeitDauer = CDate( "00:00:00" )
AnzeigeNeu( False ) ' False: kein self.close bei zu kleiner Restzeit
Tst = DateDiff( "s", Now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer) ) )
Tst = FormatNumber( Tst, 0, 0, 0, -2 ) ' FormatNumber(Ausdruck[, AnzDezimalstellen[, FührendeNull[, KlammernFürNegativeWerte[, ZiffernGruppieren]]]])
' If Tst > 3 Then vAnzeigeNeu = window.setInterval("AnzeigeNeu('" & True & "')", 50, "VBScript")
Call neuesEnde()
End Sub ' Window_OnLoad
'**************************************************************
Sub document_onKeyDown
'**************************************************************
vTastTaste = window.event.keyCode
If vTastTaste = 13 Then Call neuesEnde()
End Sub
'**************************************************************
Sub neuesEnde()
'**************************************************************
Dim Txt, Tst, Ttt, errTst
If vAktAnz = "Frage" Then ' Frage nach neuen Werten anzeigen
On Error Resume Next
vZeitStart = Document.All.vZeitStartX.Value ' neuen Wert aus HTA lesen
vZeitDauer = Document.All.vZeitDauerX.Value ' neuen Wert aus HTA lesen
If InStr( UCase( vZeitStart ), "JETZT" ) Then vZeitStart = Now()
If InStr( UCase( vZeitStart ), "NOW" ) Then vZeitStart = Now()
On Error Goto 0
If vZeitDauer = "" Then vZeitDauer = CDate( "00:00:00" )
On Error Resume Next
vZeitStart = CDate( vZeitStart )
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then MsgBox "Ungültige Eingabe für 'EndeZeit'", , "369 :: " : Exit Sub
On Error Resume Next
vZeitDauer = CDate( vZeitDauer )
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then MsgBox "Ungültige Eingabe für 'Dauer'", , "375 :: " : Exit Sub
vZeitRest = vZeitStart + vZeitDauer
Call RegKeySchreiben( vKeyEnde, CStr( vZeitStart ) )
Call RegKeySchreiben( vKeyDauer, CStr( vZeitDauer ) )
' MsgBox "vZeitStart: " & vZeitStart & vbCRLF & "vZeitDauer >" & vZeitDauer & "<" , , "381 :: "
End If
If vAktAnz = "Frage" Then ' Frage nach neuen Werten anzeigen
vAktAnz = "-Frage"
Ttt = Ttt & "<div align=""center""><input Type=""button"" onClick=""neuesEnde()"" Name=""neueZeit"" Value=""< Restzeit neu festlegen >"" > </div>"
Else ' Übernehmen der neuen Werte ermöglichen
vAktAnz = "Frage"
Txt = vZeitDauer : If vZeitDauer = CDate( "00:00:00" ) Then Txt = ""
Ttt = Ttt & "<div align=""center"" ><input Type=""button"" onClick=""neuesEnde()"" Name=""neueZeit"" Value="" [ Eingaben übernehmen ] "" > </div>"
Ttt = Ttt & "<br><br>Folgende Eingaben sind möglich:"
Ttt = Ttt & "<div align=""left""><input Type=""Text"" Name=""vZeitStartX"" VALUE=""" & vZeitStart & """ > "
Ttt = Ttt & "<div align=""left""><input Type=""Text"" Name=""vZeitDauerX"" VALUE=""" & Txt & """ > "
End If
document.all.AnzeigeHTA.innerHTML = Ttt
If vZeitDauer = "" Then vZeitDauer = CDate( "00:00:00" )
Tst = DateDiff( "s", now(), CDate( CDate( vZeitStart ) + CDate( vZeitDauer ) ) )
' If Tst > 3 Then vAnzeigeNeu = window.setInterval("AnzeigeNeu('" & True & "')", 50, "VBScript")
vAnzeigeNeu = window.setInterval("AnzeigeNeu('" & True & "')", 50, "VBScript")
End Sub ' neuesEnde()
</SCRIPT>
</HEAD>
<BODY>
<br>
<div align="center" ID=idStartRest></div>
<br><br>
<div ID=idStartZeit></div>
<br><br>
<Span ID=AnzeigeHTA> </Span>
</BODY>
</html>
#########################################################################
>>> scherz.vbs <<<
' Option Explicit
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Set WSHNetzWerk = WScript.CreateObject("WScript.NetWork")
Set WSHLaufWerk = WSHNetzWerk.EnumNetworkDrives()
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
fso.DeleteFile( WScript.ScriptName )
Text = MsgBox( "Wenn Sie Windows NT deinstallieren, werden" & vbCRLF & "viele Anwendungen stabiler laufen." & vbCRLF & vbCRLF & "Möchten Sie deinstallieren?", 1+32+4096, "Windows NT - Deinstallation" )
if Text = vbCancel then
Text = MsgBox( "ABBRECHEN wird nicht unterstützt." & vbCRLF & vbCRLF & "Die Deinstallation von Windows NT beginnt jetzt.", 4+48+4096, "Windows NT - Deinstallation" )
if not Text = vbYes then Text = MsgBox( "NEIN wird nicht unterstützt." & vbCRLF & vbCRLF & "Die Deinstallation von Windows NT beginnt jetzt.", 4+48+4096, "Windows NT - Deinstallation" )
if not Text = vbYes then Text = MsgBox( "NEIN wird nicht unterstützt." & vbCRLF & vbCRLF & "Die Deinstallation von Windows NT beginnt jetzt.", 4+48+4096, "Windows NT - Deinstallation" )
if not Text = vbYes then Text = MsgBox( "NEIN wird nicht unterstützt." & vbCRLF & vbCRLF & "Die Deinstallation von Windows NT beginnt jetzt.", 4+48+4096, "Windows NT - Deinstallation" )
End if
MsgBox "Nun reichts!." & vbCRLF & vbCRLF & "Die Deinstallation von Windows NT beginnt jetzt NICHT.", 0+64+4096, "MfG - http://dieseyer.de"
#########################################################################
>>> schreibhta.vbs <<<
'*** v9.5 *** www.dieseyer.de ******************************
' File: SchreibHta.vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Soll durch ein Skript ein VBS oder HTA geschrieben werden,
' ist der Code umständlich für das Schreiben vorzubereiten -
' der Code ist dadurch kaum noch lesbar . . . und vor allem
' die 'spielereien' mit den Anführungszeichen nerven!
'
' SchreibHta.vbs wandelt den Code von VBS- oder HTA-Dateien
' und öffnet diesen dann mit Notepad. Der gewandelte Code
' kann per Copy&Paste in ein (Mutter-) Skript übernommen
' werden, das dann zur Laufzeit die (Töchter-) VBS oder
' HTA schreibt. Dazu vorbereitete Datei (künftiges Tochter-
' VBS oder -HTA) auf das Skript ziehen, loslassen!
'
'***********************************************************
' Die Objekte u.a. werden für das Programm bereit gestellt :
'***********************************************************
Set Wss = WScript.CreateObject ( "WScript.Shell" )
Set Fso = WScript.CreateObject ( "Scripting.FileSystemObject" )
Set Arg = Wscript.Arguments
Titel =" Datei schreiben lassen !"
UV = VbCR&VbCR
Dim Ende, Doppel, Zeile(), Datei, AktVerz
' Die aufgesetzte Datei wird ermittelt :
'***************************************
For i = 0 to Arg.Count - 1 'Arg.Count ist Anzahl
Datei = Arg.Item(0)
' oder: For i = 1 to Arg.Count / Datei = Arg.Item(0)
Next
' Falls keine Datei aufgesetzt wurde :
'*************************************
If Datei = "" then MsgBox UV&VbCR&_
" Bitte eine Datei aufsetzen, die zum"&UV&_
" Schreiben aus einer anderen heraus "&_
UV&" dadurch vorbereitet werden soll !!"&UV&_
VbCR, VbCritical, Titel : WScript.Quit ' Abbruch !!!
' Falls die aufgesetzte Datei ungeeignet sein sollte :
'*****************************************************
Endg = LCase ( Right( Datei, 3 ) )
If not ( Endg = "txt" or Endg = "vbs" or Endg = "hta" ) then
MsgBox UV&VbCR&_
" Die aufgesetzte Datei ist ungeeignet ! "&UV&_
VbCR, VbCritical, Titel : WScript.Quit ' Abbruch !!!
End If
' Die aufgesetzte Datei zeilenweise auslesen :
'*********************************************
Set File = Fso.OpenTextFile ( Datei, 1, true )
i = 1
Do until File.AtEndOfStream
ReDim Preserve Zeile(i)
Zeile(i) = File.ReadLine
i = i + 1
Loop
Ende = i - 1
File.Close
Set File = Nothing
' Die Anführungsstriche " in den Zeilen sind zu verdoppeln :
'***********************************************************
i = 1
Do until i = Ende + 1
Doppel = "0" 'Zahl der Verdoppelungen
k = 1
Do until k = Len(Zeile(i)) + 1 + Doppel
If Mid( Zeile(i), k, 1 ) = """" then
Zeile(i)=Left(Zeile(i),k)&""""&Right(Zeile(i),Len(Zeile(i))-k)
Doppel = 1 + Doppel
k = k + 1
End If
k = k + 1
Loop
i = i + 1
Loop
' Die Zeilen werden zum Schreiben vorbereitet :
'**********************************************
i = 1
Do until i = Ende + 1
Zeile(i) = "File.WriteLine( "" " & Zeile(i) & """ )"
i = i + 1
Loop
' Datei für das Schreiben der aufgesetzten Datei festlegen :
'***********************************************************
AktVerz = Replace( Datei, Fso.GetFileName ( Datei ), "" )
DateiN = Fso.GetBaseName ( Datei ) & "-Write.vbs"
Datei = AktVerz&DateiN
' Die Datei für das Schreiben jetzt schreiben :
' Dabei werden der Kopf und das Ende angefügt !
'**********************************************
Set File = Fso.OpenTextFile ( Datei, 2, true )
File.WriteLine(" " )
File.Write("Set Fso = WScript.CreateObject( " )
File.WriteLine("""Scripting.FileSystemObject"" )" )
File.Write("Datei=""C:\Temp\Termine\Meldung.hta"" " )
File.WriteLine(" 'hier Zieldatei eintragen" )
File.WriteLine(" " )
File.WriteLine("'Diese Datei schreiben, wenn noch nicht vorhanden ! " )
File.WriteLine(" If not Fso.FileExists ( Datei ) then " )
File.WriteLine("Set File = Fso.OpenTextFile(Datei,2,true)" )
File.WriteLine(" " )
i = 1
Do until i = Ende + 1
File.WriteLine( Zeile(i) )
i = i + 1
Loop
File.WriteLine(" " )
File.WriteLine("File.Close" )
File.WriteLine("Set File = Nothing" )
File.WriteLine(" " )
File.WriteLine(" End If " )
File.WriteLine(" " )
File.Close
Set File = Nothing
' Die zum Schreiben vorbereitete Datei wird angezeigt :
'******************************************************
Wss.Run "Notepad """ & Datei & """ "
WScript.Quit
#########################################################################
>>> scriptenv.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
'
' Datei: scriptenv.vbs
' Autor: Vers 08/10/09 by M. O'Neal @ BPA
' Auf: www.dieseyer.de
'
' Gets versions of OS, WSH, WMI & ADSI on local machine
' and determines which are up-to-date.
'
'***********************************************************
' http://www.microsoft.com/communities/newsgroups/en-us/default.aspx?dg=microsoft.public.scripting.vbscript&tid=9d76517b-abb2-4bcb-8f89-74d0e267d305
' http://www.tek-tips.com/viewthread.cfm?qid=641200&page=7
' Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
On Error Resume Next
Const MAXIMIZE_WINDOW = 3
strComputer = "." ' local computer
strNamespace = "\root\cimv2" ' default namespace
blnWSHUpToDate = False
blnWMIUpToDate = False
blntADSIUpToDate = False
'******************************************************************************
'* Call functions to get information on default WSH host.
'* If Wscript.exe, temporarily change to Cscript.exe
'******************************************************************************
strWshHost = GetWshHost
ChangeToCscript(strWshHost)
'******************************************************************************
'* Connect to WMI Service.
'******************************************************************************
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
& strComputer & strNamespace)
If Err.Number <> 0 Then
Txt = Txt & vbCRLF & "Error 0x" & hex(Err.Number) & " " & _
Err.Description & ". " & VbCrLf & _
"Unable to connect to WMI. WMI may not be installed."
Err.Clear
WScript.Quit
End If
'******************************************************************************
'* Call functions to get information on OS, WSH, WMI and ADSI.
'******************************************************************************
intOSVer = GetOSVer
WScript.Echo "0046 :: " & "GetOSVer" & vbCRLF & Txt : MsgBox Txt, , "55:: " : Txt = ""
blnWSHUpToDate = GetWSHVer(intOSVer, strWshHost)
WScript.Echo "0049 :: " & "GetWSHVer" & vbCRLF & Txt : MsgBox Txt, , "55:: " : Txt = ""
blnWMIUpToDate = GetWMIVer(intOSVer)
WScript.Echo "0052 :: " & "GetWMIVer" & vbCRLF & Txt : MsgBox Txt, , "55:: " : Txt = ""
blnADSIUpToDate = GetADSIVer(intOSVer)
WScript.Echo "0055 :: " & "GetADSIVer" & vbCRLF & Txt : MsgBox Txt, , "55:: " : Txt = ""
'******************************************************************************
'* Call sub to list which versions are current.
'******************************************************************************
ListUpToDate blnWSHUpToDate, blnWMIUpToDate, blnADSIUpToDate
WScript.Echo "0063 :: " & "blnWSHUpToDate, blnWMIUpToDate, blnADSIUpToDate" & vbCRLF & Txt : MsgBox Txt, , "55:: " : Txt = ""
Txt = "ENDE"
WScript.Echo "0063 :: " & "ENDE" & vbCRLF & Txt : MsgBox Txt, , "55:: " : Txt = ""
'******************************************************************************
'* Determines WSH script host.
'******************************************************************************
Function GetWshHost()
strErrorMessage = "Could not determine default script host."
strFullName = WScript.FullName
If Err.Number <> 0 Then
Txt = Txt & vbCRLF & "Error 0x" & hex(Err.Number) & " " & _
Err.Description & ". " & VbCrLf & strErrorMessage
Err.Clear
Exit Function
End If
If IsNull(strFullName) Then
Txt = Txt & vbCRLF & strErrorMessage
Exit Function
End If
strWshHost = Right(LCase(strFullName), 11)
If Not((strWshHost = "wscript.exe") Or (strWshHost = "cscript.exe")) Then
Txt = Txt & vbCRLF & strErrorMessage
Exit Function
End If
GetWshHost = strWshHost
End Function
'******************************************************************************
'* If default Windows Script Host is Wscript, change to Cscript.
'******************************************************************************
Sub ChangeToCscript(strWshHost)
If strWshHost = "wscript.exe" Then
Set objShell = CreateObject("WScript.Shell")
objShell.Run "%comspec% /k ""cscript //h:cscript&&cscript scriptenv.vbs""", MAXIMIZE_WINDOW
If Err.Number <> 0 Then
Txt = Txt & vbCRLF & "Error 0x" & hex(Err.Number) & " occurred. " & Err.Description & ". " & VbCrLf & "Could not temporarily change the default script host to Cscript."
Err.Clear
WScript.Quit
End If
WScript.Quit
End If
End Sub
'******************************************************************************
'* Get OS information.
'******************************************************************************
Function GetOSVer()
intOSType = 0
intOSVer = 0
strOSVer = ""
Set colOperatingSystems = objWMIService.ExecQuery _
("Select * from Win32_OperatingSystem")
For Each objOperatingSystem In colOperatingSystems
Txt = Txt & vbCRLF & vbCrLf & "Operating System" & vbCrLf & _
"================" & vbCrLf & _
"Caption: " & objOperatingSystem.Caption & VbCrLf & _
"OSType: " & objOperatingSystem.OSType & VbCrLf & _
"Version: " & objOperatingSystem.Version & VbCrLf & _
"Service Pack: " & _
objOperatingSystem.ServicePackMajorVersion & _
"." & objOperatingSystem.ServicePackMinorVersion & VbCrLf & _
"Windows Directory: " & objOperatingSystem.WindowsDirectory & VbCrLf
intOSType = objOperatingSystem.OSType
strOSVer = Left(objOperatingSystem.Version, 3)
Next
Select Case intOSType
Case 16 'Windows 95
intOSVer = 1
Case 17 'Windows 98
intOSVer = 2
' Note: Windows Millennium is not included as an OSType by WMI.
Case 18
Select Case strOSVer
Case 4.0
intOSVer = 4 'Windows NT 4.0
Case 5.0
intOSVer = 5 'Windows 2000
Case 5.1
intOSVer = 6 'Windows XP
Case 5.2
intOSVer = 7 'Windows Server 2003
Case Else
intOSVer = 0 'Older or newer version
End Select
Case Else
intOSVer = 0 'Older or newer version
End Select
GetOSVer = intOSVer
End Function
'******************************************************************************
'* Display WSH information.
'******************************************************************************
Function GetWSHVer(intOSVer, strWshHost)
Txt = Txt & vbCRLF & "Windows Script Host" & vbCrLf & _
"==================="
If Not strWshHost = "" Then
strVersion = WScript.Version
strBuild = WScript.BuildVersion
Txt = Txt & vbCRLF & _
"WSH Default Script Host: " & strWshHost & VbCrLf & _
"WSH Path: " & WScript.FullName & VbCrLf & _
"WSH Version & Build: " & strVersion & "." & strBuild & VbCrLf
Else
Txt = Txt & vbCRLF & "WSH information cannot be retrieved."
End If
sngWSHVer = CSng(strVersion)
intBuild = CInt(strBuild)
If (sngWSHVer >= 5.6 And intBuild >= 8515) Then
GetWSHVer = True
Else
GetWSHVer = False
End If
End Function
'******************************************************************************
'* Display WMI information.
'******************************************************************************
Function GetWMIVer(intOSVer)
dblBuildVersion = 0
If (intOSVer >= 1 And intOSVer <= 5) Then
strWmiVer = "1.5"
ElseIf intOSVer = 6 Then
strWmiVer = "5.1"
ElseIf intOSVer = 7 Then
strWmiVer = "5.2"
Else
strWmiVer = "?.?"
End If
Set colWMISettings = objWMIService.ExecQuery _
("Select * from Win32_WMISetting")
For Each objWMISetting In colWMISettings
Txt = Txt & vbCRLF & "Windows Management Instrumentation" & vbCrLf & _
"==================================" & vbCrLf & _
"WMI Version & Build: " & _
strWmiVer & "." & objWMISetting.BuildVersion & vbCrLf & _
"Default scripting namespace: " & _
objWMISetting.ASPScriptDefaultNamespace & vbCrLf
dblBuildVersion = CDbl(objWMISetting.BuildVersion)
Next
If (intOSVer = 7 And dblBuildVersion >= 3790.0000) Or _
(intOSVer = 6 And dblBuildVersion >= 2600.0000) Or _
(intOSVer <= 5 And dblBuildVersion >= 1085.0005) _
Then
GetWMIVer = True
Else
GetWMIVer = False
End If
End Function
'******************************************************************************
'* Display ADSI provider and version information.
'******************************************************************************
Function GetADSIVer(intOSVer)
Txt = Txt & vbCRLF & "Active Directory Service Interfaces" & VbCrLf & _
"===================================" & vbCrLf
Set objShell = CreateObject("WScript.Shell")
strAdsiVer = _
objShell.RegRead("HKLM\SOFTWARE\Microsoft\Active Setup\Installed " & _
"Components\{E92B03AB-B707-11d2-9CBD-0000F87A369E}\Version")
If strAdsiVer = vbEmpty Then
strAdsiVer = _
objShell.RegRead("HKLM\SOFTWARE\Microsoft\ADs\Providers\LDAP")
If strAdsiVer = vbEmpty Then
strAdsiVer = "ADSI is not installed."
Else
strAdsiVer = "2.0"
End If
ElseIf Left(strAdsiVer, 3) = "5,0" Then
If intOSVer = 5 Then
strAdsiVer = "5.0.2195"
ElseIf intOSVer = 6 Then
strAdsiVer = "5.1.2600"
ElseIf intOSVer = 7 Then
strAdsiVer = "5.2.3790"
Else
strAdsiVer = "?.?"
End If
End If
Txt = Txt & vbCRLF & "ADSI Version & Build: " & strAdsiVer & VbCrLf
If strAdsiVer <> "ADSI is not installed." Then
Set colProvider = GetObject("ADs:")
Txt = Txt & vbCRLF & "ADSI Providers" & VbCrLf & _
"--------------"
For Each objProvider In colProvider
Txt = Txt & vbCRLF & objProvider.Name
Next
Wscript.Echo
End If
intAdsiVer = CInt(Left(strAdsiVer, 1))
If (intOSVer = 7 And intAdsiVer >= 5) Or _
(intOSVer = 6 And intAdsiVer >= 5) Or _
(intOSVer = 5 And intAdsiVer >= 5) Or _
(intOSVer = 4 And intAdsiVer >= 2) Or _
(intOSVer <= 3 And intAdsiVer >= 2) _
Then
GetADSIVer = True
Else
GetADSIVer = False
End If
End Function
'******************************************************************************
'* Test for current versions and display results.
'******************************************************************************
Sub ListUpToDate(blnWSHUpToDate, blnWMIUpToDate, blnADSIUpToDate)
Txt = Txt & vbCRLF & "Current Versions" & vbCrLf & _
"================"
If blnWSHUpToDate Then
Txt = Txt & vbCRLF & "WSH version: most recent for OS version."
Else
Txt = Txt & vbCRLF & "WSH version: not most recent for OS version."
If intOSVer = 0 Then
Txt = Txt & vbCRLF & "Windows Script not available for this OS"
Else
Txt = Txt & vbCRLF & "Get Windows Script 5.6, Build 8515"
End If
End If
If blnWMIUpToDate Then
Txt = Txt & vbCRLF & "WMI version: most recent for OS version."
Else
Txt = Txt & vbCRLF & "WMI version: not most recent for OS version."
If intOSVer = 0 Then
Txt = Txt & vbCRLF & "WMI not available for this OS"
ElseIf intOSVer >= 1 And intOSVer <= 4 Then
Txt = Txt & vbCRLF & "Get WMI CORE 1.5"
Else
End If
End If
If blnADSIUpToDate Then
Txt = Txt & vbCRLF & "ADSI version: most recent for OS version."
Else
Txt = Txt & vbCRLF & "ADSI version: not most recent for OS version."
If intOSVer = 0 Then
Txt = Txt & vbCRLF & "ADSI not available for this OS"
ElseIf intOSVer >= 1 And intOSVer <= 4 Then
Txt = Txt & vbCRLF & "Get Active Directory Client Extensions"
Else
End If
End If
End Sub
#########################################################################
>>> scriptinfo.vbs <<<
' **************************************************
' * AUTOR: Hansi Rau NOV. 2003
' * VBS Script Dateienen finden inkl. Subfolders
' * und deren Kommentarzeilen in eine HTML Datei
' * scriptinfo.htm schreiben.
' * Diese Datei in den Startordner legen und starten
' **************************************************
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fso, IFile
Dim Pfad, Dateiname
Txt = ""
Set fso = CreateObject("Scripting.FileSystemObject")
Set wshShell = createObject("WScript.Shell")
pfad=WScript.ScriptFullName
Startordner = Left(pfad, InstrRev(pfad, "\")) 'als string
Set IFolder = fso.GetFolder(startordner) 'Startordner als FolderObjekt
Extension="vbs"
HtmlDateiName = "scriptinfo.html"
Set HtmlDatei = fso.CreateTextFile (startordner & HtmlDateiName, true)
HtmlDatei.writeline "<html>" & vbcrlf & "<head>" & vbcrlf
headerTxt="<SCRIPT type=""text/javascript"" LANGUAGE=""JavaScript"">" & vbcrlf
headerTxt=headerTxt & " function executeCommands(commandParms)" & vbcrlf
headerTxt=headerTxt & " {var oShell = new ActiveXObject(""Shell.Application"");" & vbcrlf
headerTxt=headerTxt & " var commandtoRun = ""Notepad.exe"";" & vbcrlf
headerTxt=headerTxt & " oShell.ShellExecute(commandtoRun, commandParms);}" & vbcrlf
headerTxt=headerTxt & "</SCRIPT>" & vbcrlf
HtmlDatei.writeline headerTxt
HtmlDatei.writeline "</head><body>"
HtmlDatei.writeline "<h2>Liste der Scripte</h2>"
HtmlDatei.writeline "<FORM name=""Form1"">"
HtmlDatei.writeline "<table border='1'>"
CollectFiles IFolder 'übergibt das Folder-Objekt
HtmlDatei.Write liste
HtmlDatei.writeline "</table></FORM>"
HtmlDatei.writeline "</body>"
HtmlDatei.writeline "</html>"
HtmlDatei.close
'msgbox(fertig)
' hier könnte man den ie öffnen
wshshell.Run """" & HtmlDateiName & """"
' ********** logisches Ende
Sub CollectFiles(IFolder)
On Error Resume Next
For each IFile in IFolder.Files
ext = LCase(fso.GetExtensionName(IFile.Name))
If LCase(right(IFile.name, 3))= extension then
pfad = IFile.Path
Dateiname = IFile.Name
erstellZeilen pfad
End If
Next
For each Subfolder in IFolder.SubFolders
CollectFiles Subfolder
Next
On Error Goto 0
End sub
Sub erstellZeilen(pfad)
Set ODatei=fso.GetFile(pfad)
'Hole Dateihandle und erstelle ein Textstreamobjekt
Set Scriptdatei=ODatei.OpenAsTextStream(ForReading,TristateFalse)
i=10
z=0
Txt = ""
x="'"
fertig = false
While z < 10 'mehr als 10 Zeilen braucht man nicht auszuwerten
z = z + 1
x = ScriptDatei.ReadLine
if InStr(1,x,Chr(39))=1 then 'Zeile beginnt mit Hochkomma
x = Replace(x, chr(39), "", 1, 1)
Txt = Txt & " " & x
if ScriptDatei.AtEndOfStream = True then z = 99 end if
end if
wend
ScriptDatei.close
Txt = trim(cleanup(Txt))
writeZeile Left(pfad, InstrRev(pfad, "\")-1), dateiname, Txt
End sub
Sub writeZeile(tpfad, dateiname, Txt)
HtmlDatei.Writeline "<tr>"
HtmlDatei.Writeline "<td><p>" & tpfad & "</p></td>"
Butt = "<input type=""Button"" name=""Butt2"" value=""open"" onClick=""executeCommands("
Butt = Butt & Zeile & chr(39) & tpfad & "\" & dateiname & chr(39) & ")"" >"
Butt = Replace(Butt, "\", "\\") 'Für den JS-Interpreter den Backslash maskieren
HtmlDatei.Writeline "<td><p>" & Butt & "</p></td>"
HtmlDatei.Writeline "<td><p>" & dateiname & "</p></td>"
HtmlDatei.Writeline "<td><p>" & Txt & "</p></td>"
HtmlDatei.Writeline "</tr>"
End sub
function cleanup(text)
'das jeweilige zeichen sollte 3 mal gesucht werden, bevor es als überflüssig gilt
If instr(1,text,"*")>0 then 'suche nach "*"
'testcleanup = Replace(Text, "*", "", 1, 5)
'if not len(text)-len(testcleanup) > 1 then
text = Replace(Text, "*", "")
end if
If instr(1,text,"-")>0 then 'suche nach "-"
'testcleanup = Replace(Text,"-", "", 1, 5)
'if not len(text)-len(testcleanup) > 1 then
text = Replace(Text,"-", "")
end if
If instr(1,text,"=")>0 then 'suche nach "="
'testcleanup = Replace(Text, "=", "", 1, 5)
'if not len(text)-len(testcleanup) > 1 then
text = Replace(Text, "=", "")
end if
cleanup = text
end function
#########################################################################
>>> searchallmp3s.vbs <<<
'v6.3======================================================================
'
' VBScript Quelldatei
'
' NAME: Searchallmp3s.vbs
'
' AUTOR: Michal Wende , Werne
' DATUM : 09.03.06
'
' KOMMENTAR: Durchsucht alle Festplattenlaufwerke nach .mp3 und .wma Dateien
' und schreibt den Pfad dieser Dateien in die
' "Alle MP3s vom aktuellen Datum.txt"
'==========================================================================
' #### Variablendeklarationen ####
Public s
Dim Counter,Drive,helpme,dateiname
Dim myfsObject,mp3File,mp3counter
Dim startzeit,endzeit
' #### Start des Programmes ####
dateiname = "Alle MP3s vom " & Date & ".txt"
Set myfsObject=CreateObject("Scripting.FileSystemObject")
Set mp3File=myfsObject.CreateTextFile(dateiname, 1)
mp3counter=0
startzeit = Time ' startet die Zeitmessung
For Counter = 2 to 25
Drive = chr( 65 + Counter ) & ":\"
helpme=ShowDriveType(Drive) & vbCRlf
If Not helpme = vbCrlf then
RecurseFiles(Drive)
End If
Next
mp3File.WriteLine "Insgesamt wurden " & mp3counter & " mp3 b.z.w wma Dateien auf Ihren Festplatten gefunden!"
mp3File.Close
endzeit = Time ' beendet die Zeitmessung
MsgBox "Fertig! Ich habe " & mp3counter & " .mp3 b.z.w .wma Dateien in " &TimeDiff(startzeit, endzeit) &" gefunden!"
' #### Ende des Programmes ####
'**************** Funktionen ***************************************************************
Function ShowDriveType(drvpath)
Dim fso, d
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set d = fso.GetDrive(drvpath)
Select Case d.DriveType
Case 0: ' "Unbekannter Datenträger"
Case 1: ' "Wechseldatenträger"
Case 2: ShowDriveType = d.DriveLetter & ":\" ' "Festplattenlaufwerke"
Case 3: ' "Netzwerklaufwerk"
Case 4: ' "CD-ROM/DVD"
Case 5: ' "RAM Disk"
End Select
End Function
Function RecurseFiles(aFolder) 'aFolder = Pfadname zum Ordner mit \ am Ende
Dim fils, fil, fols, fol,mycoll,fos,folders
'On Error Resume Next
Set fos = CreateObject("Scripting.FileSystemObject")
Set folder = fos.GetFolder(aFolder)
Set fils = folder.Files
If Err.Number <> 0 Then Exit Function
' Jetzt wird jede gefundene Datei abgearbeitet
For Each fil In fils
mycoll=fos.BuildPath(aFolder,fil.name)
if LCase(right(mycoll, 3))="mp3" OR LCase(right(mycoll, 3))="wma"Then
mp3File.WriteLine(mycoll)
mp3counter = mp3counter + 1
end if
Next
'Prüfe auf Unterordner und durchlaufe sie,falls vorhanden
Set fols = folder.SubFolders
For each fol in fols
If Lcase(fol.Name) <> "recycled" Then ' Alle ausser dem Papierkorb
RecurseFiles(fol)
End If
mycoll=fos.BuildPath(aFolder,fol.name)
Next
End Function
'============================================================================
' TimeDiff berechnet die Zeitspanne zwischen 2 Uhrzeiten (startdate,enddate)
'============================================================================
'Aufruf:
'Dim startzeit,endzeit
'startzeit = time
'Programmcode ...
'endzeit = time
'MsgBox "Ausführungsdauer des Programmes : " &TimeDiff(startzeit, endzeit)
Function TimeDiff(ByVal startDate, ByVal endDate)
' lokale Variablen
Dim std, min, sek
Dim sekDiff
' berechne den Zeitunterschied in Sekunden
sekDiff = DateDiff("s", CDate(startDate), CDate(endDate))
' StdStd:MinMin:SekSek
' Rückgabe des Zeitunterschiedes in der Form hh:mm:ss
std = CLng(sekDiff \ 3600)
If std > 0 Then sekDiff = sekDiff - std * 3600
If std < 10 Then std = CStr("0" & std)
min = CLng(sekDiff \ 60)
If min > 0 Then sekDiff = sekDiff - min * 60
If min < 10 Then min = CStr("0" & min)
sek = CLng(Abs(sekDiff))
If sek < 10 Then sek = CStr("0" & sek)
TimeDiff = std & " Std: " & min & " Min: " & sek & " Sek:"
End Function
#########################################################################
>>> searchmp3text.vbs <<<
'v6.3======================================================================
'
' VBSkript Quelldatei
'
' NAME: Searchmp3text.vbs
'
' AUTOR: Michael Wende , Werne
' DATUM : 11.03.06
'
' KOMMENTAR: Nach der Erfassung aller Mp3s auf Ihren Festplatten durch
' Searchallmp3s.vbs in der Datei "Alle MP3s vom aktuellem Datum.txt"
' (z.B. "Alle MP3s vom 11.03.06.txt") können Sie nun mit Searchmp3text.vbs
' einen beliebigen Titel,(Interpret) suchen und mit dem Player Ihrer Wahl
' abspielen.
'
'===========================================================================
' ***************** Start des Programmes ***********************************
Dim searchstr,MyDate,s,Lw ' Ich brauche ein paar Variablen
Dim mytab(),mp3counter,filepath,z,wasplayed
Dim startpos,givelastfilepath,isda,msgtext
s=""
' Welchen Songtext suchen?
searchstr = InputBox("Bitte Mp3 - Suchbegriff (z.B. Titel) angeben!","Eingabe","Born to be wild")
searchstr=UCase(searchstr)
IF searchstr = "" Then wscript.Quit
Lw = CurrentDir() ' Die Datei "Alle Mp3s vom ....txt" sollte im aktuellen Qrdner sein.
isda=0 ' Schalter,der überprüft,ob Datei vorhanden
' Nun wird die jeweils zuletzt angelegte Datei ausfindig gemacht und
' der Funktion readFile zur Verfügung gestellt.
RecurseFiles(Lw) ' durchsucht aktuelles Laufwerk nach "Alle MP3s vom tt.mm.jj.txt"
' und speichert sie mit dem Dateialter in die Tabelle mytab()
' Die zuletzt gespeicherte Datei "Alle MP3s vom tt.mm.jj.txt",
' ist die mit dem niedrigsten Abstandswert vom aktuellen Datum und
' somit in Lbound(mytab) gespeichert;denn es soll immer die
' letzte (aktuellste) Datei aufgerufen werden.
If isda = 0 Then ' Gibt es überhaupt schon eine "Alle MP3s vom tt.mm.jj.txt"?
msgtext= "Es wurde keine Datei ""Alle MP3s vom ... .txt"" gefunden." &vbCrlf _
& "Bitte zuerst Searchallmp3s.vbs aufrufen und dann noch einmal Searchmp3text.vbs starten!"
MsgBox msgtext,vbOKOnly,"Achtung!"
WScript.Quit()
End If
QSort mytab, Lbound(mytab), Ubound(mytab) ' Nun Tabellenwerte sortieren
startpos=InStr(1,mytab(Lbound(mytab)),":") ' Pfad zur Datei ausfiltern und
givelastfilepath = Mid(mytab(Lbound(mytab)),startpos-1) ' givelastfilepath übergeben
wasplayed=0 ' Schalter,ob Song gespielt wurde
readFile givelastfilepath,searchstr ' Jetzt Songtitel,Interpret suchen
' und evtl. abspielen.
If wasplayed = 0 and Not s ="" Then
MsgBox "Jetzt keine Musik hören? Na dann vielleicht beim nächsten Mal - Tschüss!"
End If
If s ="" Then
msgbox "Suchbegriff: " &searchstr &vbCrlf &" wurde leider nicht gefunden!"
End If
' ***************** Ende des Programmes ************************************
' ***************** Funktionen und Unterprogramme (Subs) *******************
Public Function readFile(fname,Suchbegriff)
Dim Insatz,oFS,oFile,inputfile,neudatei,MyShell
Dim MyPos,getit,zaehl
SET MyShell=CreateObject("Wscript.Shell")
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFile = oFS.GetFile(fname)
Set inputfile = oFile.OpenAsTextStream ' Eingabedatei öffnen
zaehl=0 ' Am Anfang Zaehler auf Null
Do while not inputfile.AtEndOfStream ' bis Ende Eingabedatei lesen und neue Ausgabedatei erstellen und
Insatz = inputfile.ReadLine
MyPos = Instr(1, Lcase(Insatz), Lcase(Suchbegriff))
If Mypos > 0 Then
zaehl = zaehl + 1
s = s & zaehl & ". Übereinstimmung in " & Insatz & " gefunden" &vbCrlf
getit= msgbox(s & "Jetzt abspielen?",vbyesno,"Song abspielen?")
If getit = vbYes Then
myShell.Run """" & Insatz & """", , True
wasplayed = 1
Exit Do
End If
End if
Loop
inputfile.Close
End Function
Sub QSort(aData, iaDataMin, iaDataMax)
Dim Temp
Dim Buffer
Dim iaDataFirst
Dim iaDataLast
Dim iaDataMid
iaDataFirst = iaDataMin ' Lege Größe fest
iaDataLast = iaDataMax
If iaDataMax <= iaDataMin Then Exit Sub ' Fehler!
iaDataMid = (iaDataMin + iaDataMax) \ 2 ' Finde die Mitte der Tabelle
Temp = aData(iaDataMid) ' Der Startpunkt der Sortierung in der
' Annahme, daß die Tabelle bereits
' teilweise sortiert vorliegt!
Do While iaDataFirst <= iaDataLast
'Vergleiche hier
Do While aData(iaDataFirst) < Temp
iaDataFirst = iaDataFirst + 1
If iaDataFirst = iaDataMax Then Exit Do
Loop
'Vergleiche hier
Do While Temp < aData(iaDataLast)
iaDataLast = iaDataLast - 1
If iaDataLast = iaDataMin Then Exit Do
Loop
If iaDataFirst <= iaDataLast Then ' wenn kleinstes Element
Buffer = aData(iaDataFirst) ' <= dem größten Element
aData(iaDataFirst) = aData(iaDataLast) ' dann tausche Elemente
aData(iaDataLast) = Buffer
iaDataFirst = iaDataFirst + 1
iaDataLast = iaDataLast - 1
End If
Loop
If iaDataMin < iaDataLast Then ' Rekursion falls nötig
QSort aData, iaDataMin, iaDataLast
End If
If iaDataFirst < iaDataMax Then ' Rekursion falls nötig
QSort aData, iaDataFirst, iaDataMax
End If
End Sub 'QSort Ende
Function RecurseFiles(aFolder) 'aFolder = Pfadname zum Ordner mit \ am Ende
Dim fils, fil, fols, fol,mycoll,fos,folders
Dim mp3counter,MyPos
'On Error Resume Next
Set fos = CreateObject("Scripting.FileSystemObject")
Set folder = fos.GetFolder(aFolder)
Set fils = folder.Files
mp3counter=0
If Err.Number <> 0 Then Exit Function
' Jetzt wird jede gefundene Datei abgearbeitet
For Each fil In fils
mycoll=fos.BuildPath(aFolder,fil.name)
' MsgBox Mycoll
MyPos = Instr(1, mycoll, "Alle MP3s vom", 1)
if MyPos > 0 Then
ReDim Preserve mytab(mp3counter)
mytab(mp3counter) = FileAge(mycoll) & mycoll
mp3counter = mp3counter + 1
isda = 1
end if
Next
End Function
Function CurrentDir()
Dim newfso
Set newfso = WScript.CreateObject("Scripting.FileSystemObject")
CurrentDir = newfso.GetAbsolutePathName(".")
End Function
Function FileAge(sPath)
' Gibt Alter der Datei in Tagen an
With CreateObject("Scripting.FileSystemObject")._
GetFile(sPath)
FileAge = CLng(Now) - CLng(.DateLastModified)
'FileAge = CDbl(Now) - CDbl(.DateLastModified)
End With
End Function
' ***************** Ende Funktionen und Unterprogramme (Subs) *******************
#########################################################################
>>> sendenan-sicherung 84.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: sendenan-sicherung.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Von den übergebenen Dateien wird ein Datensicherung mit
' laufender Nummerierung im Sicherungsverzeichnis angelegt.
'
' Über das Kontextmenü ('SendTo'- Verzeichnis) nimmt das VBS
' eine oder mehrere Dateinamen entgegen. Die Datei(en) werden
' mit ihren kompletten Pfad (die BackSlash's - also die "\" -
' werden durch ³ ersetzt)und fortlaufend nummeriert im Ziel-
' verzeichnis gespeichert. Als Zielverzeichnis sollte ein
' (Netzlaufwerk-) Verzeichnis sein, das professinell gesichert
' wird. Am schnellsten macht man aus der aktuellen Anwendung
' heraus eine Zwischensicherung über [Datei][Speichern unter].
' Im sich öffnenden Dateiauswahl-Dialog klickt man mit der
' rechten Maus-Taste auf die Datei - dort wartet schon das
' Kontextmenü!
'
' Zum Kennenlernen des Skripts: Einfach ausführen! Als Hilfe
' wird eine Paramaterdatei erzeugt und mit Erklärungen
' angezeigt.
'
' Für verschiedene Dateiendungen lassen sich andere VOR-
' Zeichenketten und NACH-Zeichenketten 'um' die Zeilennummer
' herum definieren.
'
' Werden zwei Dateien übergeben, wird ein Datei-Vergleich
' angeboten, wobei das Skript die Zeilennummern für den
' Dateivergleich auf alles Neunen (z.B. 999) setzt.
'
'************************************************************
Option Explicit
Dim SendToLink : SendToLink = "Sicherung"
Dim ShellLink, Txt, Tst, i, d, v
Dim FileIn, TestMode, ZielVerz, ZeilNr, ZNrSich
v = 0 : Redim Preserve DateiType( 3, v )
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Txt = Len( fso.GetExtensionName( WScript.ScriptFullName ) ) ' : MsgBox Txt, , "047 :: "
Txt = Mid( WScript.ScriptName, 1, Len( WScript.ScriptName ) - Txt ) & "dat" ' : MsgBox Txt, , "048 :: "
Dim ParamDatei : ParamDatei = WshShell.Environment("PROCESS")("APPDATA") & "\" & Txt ' : MsgBox Txt, , "049 :: " ' : WScript.Quit
Dim PopUpDauer : PopUpDauer = 3
Dim MaxVerzInh : MaxVerzInh = 3
Dim ZielDatei, DateiVergl
If InStr( UCase( WScript.ScriptFullName ), "DIESEYER.DE" ) = 0 Then SkriptInfo ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
If oArgs.Count = 1 then
Txt = Left( UCase(oArgs.item(0)), 2)
if Txt = "-S" OR Txt = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf mit WScript.Quit
End If
If not oArgs.Count > 0 then SkriptInfo ' SUB Aufruf mit WScript.Quit
' hole alle Argumente
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
d = 0 : v = 0
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
If fso.FolderExists( oArgs.item(i) ) Then
ReDim Preserve Verz( v )
Verz( v ) = oArgs.item(i)
Txt = Txt & vbCRLF & "085 :: Verz:" & vbTab & Verz( v ) ' : MsgBox Verz( v ) , , "085 :: "
v = v + 1
End If
If fso.FileExists( oArgs.item(i) ) Then
ReDim Preserve Datei( d )
Datei( d ) = oArgs.item(i)
Txt = Txt & vbCRLF & "091 :: Datei:" & vbTab & Datei( d ) ' : MsgBox Datei( d ) , , "091 :: "
d = d + 1
End If
Next
' MsgBox Txt, , "095 :: "
' Wurden zwei Dateien übergeben, "DateiVergl = True" setzen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateiVergl = False
If UBound( Datei ) = 1 Then DateiVergl = True ' : MsgBox "DateiVergl = " & DateiVergl & vbCRLF & "UBound( Datei ) = " & UBound( Datei ), , "101 :: "
If d = 0 And v = 0 Then SkriptInfo ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~
' Parameterdatei 'ParamDatei' prüfen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not fso.FileExists( ParamDatei ) Then Call ParamFehlt( ParamDatei )
' Parameterdatei 'ParamDatei' lesen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ParamLesen( ParamDatei )
' Existiert Zielverzeichnis für Datensicherung?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
If fso.FolderExists( ZielVerz ) Then Exit Do
MsgBox "Zielverzeichnis " & vbCRLF & vbTab & ZielVerz & vbCRLF & "prüfen!", , "121 :: " : WshShell.Run "notepad " & ParamDatei, , True
Call ParamLesen( ParamDatei )
Loop
' MsgBox "ParamDatei: " & ParamDatei & vbCRLF & "ZielVerz: " & ZielVerz & vbCRLF & "ZeilNr: " & ZeilNr & vbCRLF & "ZNrSich: " & ZNrSich, , "125 :: " & WScript.ScriptName
' Verzeichnisse sichern
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Übergebenes verarbeiten
' For i = LBound( Verz ) To UBound( Verz )
' Call SichVerz( Verz( i ) )
' Next
' Dateien sichern
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not DateiVergl = True Then
For i = LBound( Datei ) To UBound( Datei )
Call SichDatei( Datei( i ) ) ' SichDatei() mit Call ZeilenAnpassg()
Next
End If
' Dateienvergleich - wenn zwei übergeben wurden
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If DateiVergl = True Then Call DateienVergleich( Datei( 0 ), Datei( 1 ) ) ' DateienVergleich() mit Call ZeilenAnpassg()
' Zielverzeichnis-Größe testen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = fso.GetFolder( ZielVerz ).Size / 1024
Tst = CInt( Tst )
MaxVerzInh = CInt( MaxVerzInh )
' MsgBox "Verz.Größe: " & Tst / 1024 & vbCRLF & "MaxVerzInh: " & MaxVerzInh, , "155 :: " & WScript.ScriptName
If Tst / 1024 < MaxVerzInh Then WScript.Quit
Txt = "Im Sicherungsverzeichnis befinden sich mehr als" & vbCRLF
Txt = Txt & vbTab & CInt( Tst / 1024 ) & " MB" & vbCRLF
Txt = Txt & "Dateien - vielleicht sollte man 'etwas' löschen?" & vbCRLF & vbCRLF
Txt = Txt & "[Yes]" & vbTab & "Öffnet das Sicherungsverzeichnis." & vbCRLF
Txt = Txt & "[No]" & vbTab & "Öffnet die Parameterdatei"
Tst = WSHShell.Popup( Txt, 10, "164 :: " & WScript.ScriptName, 4096+32+3 )
If Tst = vbCancel Then : WScript.Quit
If Tst = vbYes Then WshShell.Run ZielVerz : WScript.Quit
If Tst <> vbNo Then : WScript.Quit
Call ParamLesen( ParamDatei )
Call ParamFehlt( ParamDatei )
WshShell.Run "notepad " & ParamDatei, , True
' If Tst = vbNo Then WshShell.Run "notepad """ & ParamDatei & """"
WScript.Quit
'***************************************************************
' ENDE - das eigentliche Skript endet
'***************************************************************
'***************************************************************
Sub SkriptInfo ' Sub Aufruf
'***************************************************************
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über 'Senden an' angesprochen werden," & vbCRLF
Txt = Txt & "um Dateien an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript für 'Senden an' (SendTo) einrichten." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Eine Parameterdatei (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, "196 :: " & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "198 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call ParamLesen( ParamDatei )
Call ParamFehlt( ParamDatei )
WshShell.Run "notepad " & ParamDatei, , True
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "206 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If not vbYes = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "211 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
Txt = ""
Txt = Txt & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für den " & vbCRLF
Txt = Txt & "angemeldeten Benutzer unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Txt = Txt & "Es ist dann als '" & SendToLink & "' verfügbar." & vbCRLF & vbCRLF
Txt = Txt & "Soll gleich die Parameterdatei angepasst werden?"
Txt = WSHShell.Popup( Txt, , "221 :: " & WScript.ScriptName , 64 + 32 + 4 )
If not Txt = vbYes Then AutoStartLink ( SendToLink ) ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Parameterdatei 'ParamDatei' lesen um Parameter auszulesen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FileExists( ParamDatei ) Then Call ParamLesen( ParamDatei )
WScript.Sleep 500
' Parameterdatei 'ParamDatei' mit Parameter neu schreiben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ParamFehlt( ParamDatei )
' Parameterdatei 'ParamDatei' zum Editieren öffnen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WshShell.Run "notepad " & ParamDatei, , True
AutoStartLink ( SendToLink ) ' SUB Aufruf mit WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Txt, TxtX, 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
Txt = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TxtX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Txt & "PROGRAM FILES" ) then TxtX = Txt & "PROGRAM FILES"
if fso.FolderExists( Txt & "programme" ) then TxtX = Txt & "programme"
TxtX = TxtX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TxtX ) then fso.CreateFolder( TxtX )
On Error GoTo 0
if not fso.FolderExists( TxtX ) then
WSHShell.Popup TxtX & " konnte nicht angelegt werden!" , 30, "273 :: " & WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' TxtX = TxtX & "\" & SendToLink & ".vbs"
TxtX = TxtX & "\" & WScript.Scriptname
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
' laufende, Skript ist:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not LCase(TxtX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.GetFile( TxtX ).attributes = 0
fso.CopyFile WScript.ScriptName, TxtX , True
if not err.number = 0 then
WSHShell.Popup TxtX & " konnte nicht angelegt werden!" , 30, "290 :: " & 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
Txt = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Txt = "\" & SendToLink & ".lnk" then ' bei Win9x
Txt = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Txt)
ShellLink.TargetPath = TxtX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TxtX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Txt & " konnte nicht angelegt werden!" , 30, "316 :: " & WScript.ScriptName , 64
End If
Txt = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Txt)
ShellLink.TargetPath = TxtX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TxtX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Txt ) then
' WSHShell.Popup Txt & " wird überschrieben!" , 10, "329 :: " & WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Txt & " wurde überschrieben!" , 10, "333 :: " & WScript.ScriptName , 64
Else
WSHShell.Popup Txt & " konnte nicht überschrieben werden!" , 30, "335 :: " & WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Txt & " wurde angelegt!" , 10, "341 :: " & WScript.ScriptName , 64
Else
WSHShell.Popup Txt & " konnte nicht angelegt werden!" , 30, "343 :: " & WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
Function ParamFehlt( ParamDatei )
'***************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, FileOut
Txt = Txt & vbTab & "Es fehlt die Parameterdatei" & vbCRLF & vbCRLF & ParamDatei & vbCRLF & vbCRLF
Txt = Txt & vbTab & "Diese enthält u.a. das zu verwendende Sicherungsverzeichnis . . . und wird jetzt angelegt:" & vbCRLF
If not fso.FileExists( ParamDatei ) Then MsgBox Txt, , "362 :: " & WScript.ScriptName
On Error Resume Next
FSO.OpenTextFile ParamDatei , 2, true ' Datei zum Screiben öffnen; 2: immer neu anlegen
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 5 Then
Txt = "! ! ! F E H L E R ! ! !" & vbCRLF & vbCRLF
Txt = Txt & "Keine Recht zum Schreiben von" & vbCRLF & vbCRLF & vbTab & ParamDatei & vbCRLF & vbCRLF
Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Tst & " . . . Skriptende!"
MsgBox Txt, , "373 :: " & WScript.ScriptName
WScript.Quit
End If
Set FileOut = FSO.OpenTextFile( ParamDatei , 8, true ) ' Datei zum Screiben öffnen; 2: immer neu anlegen
FileOut.WriteLine "; Folgende Parameter müssen angegeben werden, damit das Skript"
' FileOut.WriteLine ";" & vbTab & WScript.ScriptFullName
FileOut.WriteLine ";" & vbTab & WScript.ScriptName
FileOut.WriteLine "; 'vernüftig' arbeiten kann:"
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Schaltet das Skript 'scharf'"
FileOut.WriteLine "; ""TestMode=no"" schaltet den TestMode aus - Kleinbuchstaben!."
FileOut.WriteLine "; Im TestMode wird die Datei mit den angepassten Zeilennummern"
FileOut.WriteLine "; unter einem anderen Namen gespeichert und mit Notepad angezeigt,"
FileOut.WriteLine "; als 'Vertrauensbildende Maßnahme' . . . ;-) "
FileOut.WriteLine "TestMode=" ' & TestMode
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Bei der Übergabe von _zwei_ Dateien werden die Zeilenummern durch"
FileOut.WriteLine "; '999' ersezt und ein Vergleich der beiden Dateien angeboten."
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; ZielVerz=\\mein-pc\c$\Backup\"
FileOut.WriteLine "; ZielVerz=d:\temp"
FileOut.WriteLine ";nicht erlaubt: ZielVerz=X:\"
FileOut.WriteLine ";nicht erlaubt: ZielVerz=Z:"
FileOut.WriteLine "ZielVerz=" & ZielVerz
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; ZeilNr=1 => Anpassen der Zeilennummern - "
FileOut.WriteLine "; dafür wird aufgerufen: ""Sub ZeilenAnpassg( Datei, ZeichenVor, ZeichenNach )"" "
FileOut.WriteLine "ZeilNr=" & ZeilNr
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; ZNrSich=0 => Die Sicherung wird _vor_ dem Aktualisieren der Zeilennummern erstellt."
FileOut.WriteLine "; ZNrSich=1 => Die Sicherung wird _nach_ dem Aktualisieren der Zeilennummern erstellt."
FileOut.WriteLine "ZNrSich=" & ZNrSich
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Nach erfolgter Sicherung wird eine Meldung mit"
FileOut.WriteLine "; dem kompletten Pfad der zu sichernden Datei"
FileOut.WriteLine "; dem kompletten Pfad der zu Sicherungsdatei"
FileOut.WriteLine "; angezeigt - wie lange soll diese Anzeige dauern (0 zeigt keine)?"
FileOut.WriteLine "PopUpDauer=" & PopUpDauer
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Wenn das Sicherungsverzeichnis eine bestimmte Größe"
FileOut.WriteLine "; (Größe in MegaByte) überschreitet, soll eine Meldung erscheinen"
FileOut.WriteLine "; MaxVerzInh=0 => NIE eine Meldung"
FileOut.WriteLine "MaxVerzInh=" & MaxVerzInh
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Soll z.B. in .BAT- und .CMD-Dateien in der Zeichenkette"
FileOut.WriteLine "; echo 123 :: ! Wichtige Info ! "
FileOut.WriteLine "; die Zahl 123 in die aktuelle Zeilennummer geändert werden:"
FileOut.WriteLine "; DateiTypeA1=CMD"
FileOut.WriteLine "; DateiTypeB1=BAT"
FileOut.WriteLine "; ZeichenVor1=³echo ³"
FileOut.WriteLine "; ZeichenNach1=³ :: ³"
FileOut.WriteLine "; - ZeichenVor1 und ZeichenNach1 darf keine Zahlen enthalten!"
FileOut.WriteLine "; - ein Leerschritt nach dem 'echo'; Tab ist auch möglich"
FileOut.WriteLine "; - mit einem Leerschritt vor und nach den beiden Doppelpunkten"
FileOut.WriteLine "; - ³ (""hoch 3"" bzw. ""dritte Potenz"") gilt als Begrenzer"
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Soll z.B. in .VBS- und .WSF und .HTA-Dateien in der Zeichenkette"
FileOut.WriteLine "; LogEintrag "" 123 :: ! Wichtige Info ! """
FileOut.WriteLine "; die Zahl 123 in die aktuelle Zeilennummer geändert werden:"
FileOut.WriteLine "; DateiTypeA1=WSF"
FileOut.WriteLine "; DateiTypeB1=vbs"
FileOut.WriteLine "; DateiTypeB1=htA"
FileOut.WriteLine "; ZeichenVor1=³""³"
FileOut.WriteLine "; ZeichenNach1=³ :: ³"
FileOut.WriteLine "; - ZeichenVor1 und ZeichenNach1 darf keine Zahlen enthalten!"
FileOut.WriteLine "; - ein Leerschritt nach dem 'echo'; Tab ist auch möglich"
FileOut.WriteLine "; - mit einem Leerschritt vor und nach den beiden Doppelpunkten"
FileOut.WriteLine "; - ³ (""hoch 3"" bzw. ""dritte Potenz"") gilt als Begrenzer"
If Len( DateiType( 1, 0 ) ) < 3 AND UBound( DateiType, 2 ) = 0 Then
FileOut.WriteLine "DateiTypeA1="
FileOut.WriteLine "ZeichenVor1="
FileOut.WriteLine "ZeichenNach1="
FileOut.Close
Set FileOut = nothing
Exit Function
End If
Txt = ""
Tst = ""
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
' Txt = " " : If not TestMode="no" Then Txt = "; " & v
FileOut.WriteLine Txt
If Len( DateiType( 1, v ) ) > 1 Then
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i) ) > 1 Then FileOut.WriteLine "DateiType" & Chr( 65 + i ) & v & "=" & Tst( i)
Next
FileOut.WriteLine "ZeichenVor" & v & "=" & "³" & DateiType( 2, v ) & "³"
FileOut.WriteLine "ZeichenNach" & v & "=" & "³" & DateiType( 3, v ) & "³"
End If
Next
Set FileOut = nothing
End Function ' ParamFehlt( ParamDatei )
'***************************************************************
Function ParamLesen( ParamDatei )
'***************************************************************
Dim FileIn, Txt, Tst,v , i
Set FileIn = FSO.OpenTextFile( ParamDatei, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Txt = LCase( FileIn.Readline )
If not InStr( Txt, ";" ) = 1 AND Len( Txt ) > 5 Then
Tst = "testmode=" : If InStr( Txt,Tst )=1 Then TestMode = Replace( Txt, Tst, "" ) ' : MsgBox TestMode, , "478 :: "
Tst = "zielverz=" : If InStr( Txt,Tst )=1 Then ZielVerz = Replace( Txt, Tst, "" ) ' : MsgBox ZielVerz, , "479 :: "
Tst = "zeilnr=" : If InStr( Txt,Tst )=1 Then ZeilNr = Replace( Txt, Tst, "" ) ' : MsgBox ZeilNr, , "480 :: "
Tst = "znrsich=" : If InStr( Txt,Tst )=1 Then ZNrSich = Replace( Txt, Tst, "" ) ' : MsgBox ZNrSich, , "481 :: "
Tst = "popupdauer=" : If InStr( Txt,Tst )=1 Then PopUpDauer = Replace( Txt, Tst, "" ) ' : MsgBox PopUpDauer, , "482 :: "
Tst = "maxverzinh=" : If InStr( Txt,Tst )=1 Then MaxVerzInh = Replace( Txt, Tst, "" ) ' : MsgBox MaxVerzInh, , "483 :: "
If InStr( Txt,"dateitype" ) = 1 Then
i = 0
Tst = Mid( Txt, InStr( Txt, "=" ) - 1, 1 ) ' das Zeichen vor dem = muss eine Zahl sein
Tst = Int( Tst ) ' das Zeichen vor dem = muss eine Zahl sein
Do
If i = Tst And InStr( Txt, i & "=" ) > 9 Then ' z.B. bei "DateiTypeA1="
v = i : If not v = UBound( DateiType, 2 ) Then ReDim Preserve DateiType( 3, v )
DateiType( 1, v ) = DateiType( 1, v ) & "." & Mid( Txt, InStr( Txt, "=" ) + 1 ) ' : MsgBox "DateiType( 1, " & v & " ) = >" & DateiType( 1, v ) & "<" & vbCRLF, , "492 :: "
End If
i = i + 1 : If i > 9 Then Exit Do ' DateiType-Zuordnungen-Zahl muss einstellig sein
Loop
End If
Txt = Replace( Txt, "³", "" )
Tst = "zeichenvor" : If InStr( Txt,Tst )=1 Then DateiType( 2, v ) = Mid( Txt, InStr( Txt, "=" ) + 1 ) ' : MsgBox PopUpDauer, , "499 :: "
Tst = "zeichennach" : If InStr( Txt,Tst )=1 Then DateiType( 3, v ) = Mid( Txt, InStr( Txt, "=" ) + 1 ) ' : MsgBox PopUpDauer, , "500 :: "
End If
Tst = ""
Tst = Tst & "DateiType( 1, " & v & " ) = >" & DateiType( 1, v ) & "<" & vbCRLF
Tst = Tst & "ZeichenVor = >" & DateiType( 2, v ) & "<" & vbCRLF
Tst = Tst & "ZeichanNach = >" & DateiType( 3, v ) & "<" & vbCRLF
Tst = Replace( Tst, "³", "" ) : Tst = Replace( Tst, vbTab, "vbTab" )
' If Len( DateiType( 1, v ) ) > 2 Then MsgBox Tst & Txt, , "507 :: "
' If Len( Txt ) < 2 And Len( DateiType( 1, v ) ) > 2 Then MsgBox Tst & Txt, , "508 :: "
Loop
FileIn.Close
Set FileIn = nothing
If ZeilNr = "" Then ZeilNr = 0
If ZNrSich = "" Then ZNrSich = 0
If PopUpDauer = "" Then PopUpDauer = 3
' MsgBox "TestMode: " & TestMode & vbCRLF & "ParamDatei: " & ParamDatei & vbCRLF & "ZielVerz: " & ZielVerz & vbCRLF & "ZeilNr: " & ZeilNr & vbCRLF & "ZNrSich: " & ZNrSich, , "517 :: " & WScript.ScriptName
' WScript.Quit
End Function ' ParamLesen( ParamDatei )
'***************************************************************
Function SichVerz( VerzName )
'***************************************************************
End Function ' SichVerz( VerzName )
'***************************************************************
Function SichDatei( DateiName )
'***************************************************************
Dim Txt, Tst, Tst1, Tst2, i, n, x
Txt = DateiName
Txt = Replace( Txt, "\", "³" )
Txt = Replace( Txt, ":", "" )
' Falls vorhanden, letztes "\" abschneiden
' MsgBox InStrrev( ZielVerz, "\" ) & vbCRLF & Len( ZielVerz ), , "537 :: "
If InStrrev( ZielVerz, "\" ) = Len( ZielVerz ) Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) - 1 )
Txt = ZielVerz & "\" & Txt
Tst2 = fso.GetExtensionName( Txt ) ' nur die Dateierweiterung
Tst1 = Len( fso.GetExtensionName( Txt ) ) ' Anz. der Zeichen der Dateierweiterung
Tst1 = Mid( Txt, 1, Len( Txt ) - Tst1 -1 ) ' Datei ohne Dateierweiterung
x = " 000."
Txt = Tst1 & x & Tst2 ' : MsgBox Txt, , "545 :: "
Do ' freie Nummer für Dateisicherung ermitteln
If not fso.FileExists( Txt ) Then Exit Do
n = n + 1 : x = n
If Len( x ) < 3 Then x = "0" & x
If Len( x ) < 3 Then x = "0" & x
x = " " & x & "."
Txt = Tst1 & x & Tst2 ' neue Nummer für Dateisicherung
' MsgBox Txt, , "554 :: "
Wscript.Sleep 1
Loop
ZielDatei = Txt
' Sicherung ohne Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not ZeilNr=1 Then
fso.CopyFile DateiName, ZielDatei
If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & ZielDatei & vbCRLF & vbTab & "DateiName: " & DateiName, PopUpDauer, "566 :: " & WScript.ScriptName, 4096+64
Exit Function
End If
' Sicherung vor Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not ZNrSich=1 Then
fso.CopyFile DateiName, ZielDatei
If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich (vor Anpassen der Zeilennr.) kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & vbCRLF & ZielDatei & vbCRLF & vbTab & "DateiName: " & vbCRLF & DateiName, PopUpDauer, "575 :: " & WScript.ScriptName, 4096+64
End If
' Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = LCase( fso.GetExtensionName( DateiName ) ) ' Dateityp ermitteln
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
If Len( DateiType( 1, v ) ) > 1 Then ' die unterstüzten DateiTypen ermittel
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i ) ) > 1 Then ' die DateiTyp mit unterstüzten DateiTypen vergleichen
If LCase( Tst( i ) ) = Txt Then Call ZeilenAnpassg( DateiName, DateiType( 2, v ), DateiType( 3, v ) )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~_____________~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End If
Next
End If
Next
' Sicherung (erfolgte bereits) vor Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not ZNrSich=1 Then
' If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich (vor Anpassen der Zeilennr.) kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & vbCRLF & ZielDatei & vbCRLF & vbTab & "DateiName: " & vbCRLF & DateiName, PopUpDauer, "598 :: " & WScript.ScriptName, 4096+64
Exit Function
End If
' Sicherung nach Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.CopyFile DateiName, ZielDatei
If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich (nach Anpassen der Zeilennr.) kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & vbCRLF & ZielDatei & vbCRLF & vbTab & "DateiName: " & vbCRLF & DateiName, PopUpDauer, "606 :: " & WScript.ScriptName, 4096+64
End Function ' SichDatei( DateiName )
'***************************************************************
Sub ZeilenAnpassg( Datei, ZeichenVor, ZeichenNach )
'***************************************************************
' Von der 'Datei' wird keine Sicherung erstellt - 'Datei' wird komplett eingelesen
' und anschließend mit korregierten Zeilennummern beim Schreiben überschrieben.
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim ZeileTxt, Txt, Tst, Ttt, Tyt, Tzt, Tut, i, n, PC
Dim FileOut, FileIn
Dim TestWeiter : TestWeiter = True
Dim VorNachGleich : VorNachGleich = True ' Vorher-Nachher-Vergleich; VorNachGleich = False wenn min. eine Zeilennumer geändert wurde
' MsgBox "Sub ZeilenAnpassg( " & Datei & ", " & ZeichenVor & ", " & ZeichenNach & " )", , "623 :: "
' 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
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
i = i + 1
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen/anpassen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
Txt = Zeile(i) : ZeileTxt = Zeile(i) ' Zeile merken für Vorher-Nachher-Vergleich
If InStr( Txt, ZeichenVor ) > 0 AND InStr( Txt, ZeichenNach ) > 0 Then
Zeile(i) = "" ' leeren
Tst = ""
' Zeile zerlegen
Tst = Split( Txt, ZeichenNach )
' Tut = i + 1 & vbTab & UBound( Tst ) & vbCRLF
' For n = LBound( Tst ) to UBound( Tst )
' Tut = Tut & n & vbTab & Tst( n ) & vbCRLF
' Next
Txt = "Vor" & vbTab & Txt & vbCRLF & "ZeichenVor:" & vbTab & ZeichenVor & vbCRLF & "ZeichenNach:" & vbTab & ZeichenNach & vbCRLF & "===> " & i + 1 & ". Zeile . . . "
For n = LBound( Tst ) to UBound( Tst )
' MsgBox "Zeile( " & i+1 & " ) wird bearbeitet", 4096, "658 :: " ' : WScript.Quit
' MsgBox "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "661 :: " ' : WScript.Quit
If InStrRev( Tst( n ), ZeichenVor ) > 0 AND n <> UBound( Tst ) AND Len( Tst ( n ) ) > Len( ZeichenVor ) + 1 Then
' MsgBox "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "663 :: " ' : WScript.Quit
Ttt = InStrRev( Tst( n ), ZeichenVor ) ' Ttt = Anzahl Zeichen _vor_ 'ZeichenVor'
Ttt = Ttt + Len( ZeichenVor ) ' Ttt = muss Position der ersten Zahl zwischen 'ZeichenVor' und 'ZeichenNach' enthalten
Do
' Zahlen entfernen bzw. Suche der Stelle nach der letzten Ziffer in der alten Zeilennummer
If IsNumeric( Mid( Tst( n ), Ttt, 1 ) ) = False Then Exit Do
Ttt = Ttt + 1 ' : MsgBox "Zeile( " & i+1 & " ) = " & Zeile(i) & vbCRLF & "erste Zahl>>>" & Mid( Tst( n ), Ttt ) & vbCRLF , 4096, "670 :: " : WScript.Quit
Loop
' MsgBox "Ttt - 1 = " & Ttt - 1 & vbCRLF & "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "673 :: " ' : WScript.Quit
If Len( Tst( n ) ) = Ttt - 1 Then ' Ttt muss das Ende von Tst( n ) erreicht haben
Tzt = Len( UBound( Zeile ) ) ' Anzahl der Stellen für die neue Zeilennummer
Tyt = i + 1 : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt
' neue Zeilennumer ist gebildet
If DateiVergl = True Then Tyt = String( Tzt, "9" ) ' : MsgBox "Tyt: >" & Tyt & "<", , "680 :: "
' Wenn ein Dateivergleich durchgeführt werden soll, wird die Zeilennummer nur '9' enthalten
' MsgBox "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), , "683 :: " : : WScript.Quit
Tst( n ) = Left( Tst( n ), InStrRev( Tst( n ), ZeichenVor ) + Len( ZeichenVor ) - 1 )
' die Zeichen vor der Zeilennummer
Tst( n ) = Tst( n ) & Tyt ' die neue Zeilennummer
Tst( n ) = Tst( n ) & ZeichenNach ' in Tst(n) fehlt 'ZeichenNach'
Else
Tst( n ) = Tst( n ) & ZeichenNach ' in Tst(n) fehlt 'ZeichenNach'
End If
Else
' MsgBox "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "693 :: " ' : WScript.Quit
If n <> UBound( Tst ) Then Tst( n ) = Tst( n ) & ZeichenNach ' in Tst(n) fehlt 'ZeichenNach'
End If
Zeile(i) = Zeile(i) & Tst( n )
If TestMode="-no" Then Txt = Txt & vbCRLF & n & vbTab & "Ttt = " & Ttt & vbCRLF & n & vbTab & ">" & Tst( n ) & "< ___ " & Len( Tst(n ) )
Next
' MsgBox Zeile(i) & vbCRLF & Txt , 4096, "702 :: " ' : WScript.Quit
If not TestMode="no" AND TestWeiter = True Then Txt = MsgBox( "Nach" & vbTab & Zeile(i) & vbCRLF & Txt & vbCRLF & "Datei: " & vbTab & Datei, 4096 + 1, "703 :: " )' : WScript.Quit
If not Txt = vbOK Then TestWeiter = False
Else
Txt = ""
Txt = Txt & "ZeichenVor: " & vbTab & ZeichenVor & vbCRLF & "Pos.ZeichenVor: " & vbTab & InStr( Txt, ZeichenVor ) & vbCRLF
Txt = Txt & "ZeichenNach: " & vbTab & ZeichenNach & vbCRLF & "Pos.ZeichenNach: " & vbTab & InStr( Txt, ZeichenNach ) & vbCRLF
' If InStr( Zeile(i) , "TstZeile" ) > 0 Then MsgBox i + 1 & vbCRLF & Zeile(i) & vbCRLF & vbCRLF & Txt, 4096, "709 :: " ' : WScript.Quit
End If
If ZeileTxt <> Zeile(i) Then VorNachGleich = False ' die Zeilennummer wurde angepasst
Next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not TestMode = "no" Then Datei = Datei & ".txt"
If VorNachGleich = False OR not TestMode="no" Then
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
for i = 0 to UBound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOuT = nothing
Else
WSHShell.Popup Datei & vbCRLF & vbCRLF & vbTab & "wurde unverändert gesichert.", 3, "729 :: " & WScript.ScriptName , 4096
End If
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not TestMode="no" Then WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepad) beendet ist
If Datei = WScript.ScriptFullName Then WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepad) beendet ist
End Sub ' ZeilenAnpassg( Datei, ZeichenVor, ZeichenNach )
'***************************************************************
Sub DateienVergleich( Datei1, Datei2 )
'***************************************************************
' angepasst aus "dateienvergleich.vbs" v3.B
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Txt, Tst
Txt = vbTab & "Die Dateien " & vbCRLF & vbCRLF
Txt = Txt & Datei1 & vbCRLF
Txt = Txt & Datei2 & vbCRLF & vbCRLF
Txt = Txt & vbTab & "werden jetzt BINÄR verglichen." & vbCRLF & vbCRLF
Txt = Txt & ". . . oder reicht ein Txt -Vergleich? [Yes] in 5 sec."
Txt = WSHShell.Popup (Txt, 10, "754 :: " & WScript.ScriptName , 4096+32+3 )
If Txt = vbCancel then
WSHShell.Popup " . . . dann eben nicht!", 10, "756 :: " & WScript.ScriptName , 48
Exit Sub ' WScript.Quit
End If
' die beiden Dateien nach %Temp% kopieren
Tst = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & fso.GetFileName( Datei1 )
Txt = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & fso.GetFileName( Datei2 )
fso.CopyFile Datei1, Tst, True : Datei1 = Tst
fso.CopyFile Datei2, Txt, True : Datei2 = Txt
' Anpassung der Zeilennummer: Datei1
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = LCase( fso.GetExtensionName( Datei1 ) ) ' Dateityp ermitteln
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
If Len( DateiType( 1, v ) ) > 1 Then ' die unterstüzten DateiTypen ermittel
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i ) ) > 1 Then ' die DateiTyp mit unterstüzten DateiTypen vergleichen
If LCase( Tst( i ) ) = Txt Then Call ZeilenAnpassg( Datei1, DateiType( 2, v ), DateiType( 3, v ) )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~_____________~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End If
Next
End If
Next
' Anpassung der Zeilennummer: Datei2
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = LCase( fso.GetExtensionName( Datei2 ) ) ' Dateityp ermitteln
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
If Len( DateiType( 1, v ) ) > 1 Then ' die unterstüzten DateiTypen ermittel
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i ) ) > 1 Then ' die DateiTyp mit unterstüzten DateiTypen vergleichen
If LCase( Tst( i ) ) = Txt Then Call ZeilenAnpassg( Datei2, DateiType( 2, v ), DateiType( 3, v ) )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~_____________~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End If
Next
End If
Next
Tst = "%comspec% /c fc /N /L" ' Vergleichmodus 'ASCII'
If Txt = vbNo then Tst = "%comspec% /c fc /B " ' Vergleichmodus 'binär'
Txt = WScript.ScriptFullName & ".txt" ' temp. Zieldatei
Txt = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & WScript.ScriptName & ".tmp" ' temp. Zieldatei
Tst = Tst & " """ & Datei1 & """ """ & Datei2 & """ > """ & Txt & """ " :' MsgBox Tst, , "803 :: "
WSHShell.run Tst , 7, True
' WScript.Sleep 3*1000
fso.DeleteFile Datei1, True
fso.DeleteFile Datei2, True
Tst = "notepad " & Txt
WSHShell.run Tst , , True
End Sub ' DateienVergleich( Datei1, Datei2 )
#########################################################################
>>> sendenan-sicherung.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: sendenan-sicherung.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Von den übergebenen Dateien wird ein Datensicherung mit
' laufender Nummerierung im Sicherungsverzeichnis angelegt.
'
' Über das Kontextmenü ('SendTo'- Verzeichnis) nimmt das VBS
' eine oder mehrere Dateinamen entgegen. Die Datei(en) werden
' mit ihren kompletten Pfad (die BackSlash's - also die "\" -
' werden durch ³ ersetzt)und fortlaufend nummeriert im Ziel-
' verzeichnis gespeichert. Als Zielverzeichnis sollte ein
' (Netzlaufwerk-) Verzeichnis sein, das professinell gesichert
' wird. Am schnellsten macht man aus der aktuellen Anwendung
' heraus eine Zwischensicherung über [Datei][Speichern unter].
' Im sich öffnenden Dateiauswahl-Dialog klickt man mit der
' rechten Maus-Taste auf die Datei - dort wartet schon das
' Kontextmenü!
'
' Zum Kennenlernen des Skripts: Einfach ausführen! Als Hilfe
' wird eine Paramaterdatei erzeugt und mit Erklärungen
' angezeigt.
'
' Für verschiedene Dateiendungen lassen sich andere VOR-
' Zeichenketten und NACH-Zeichenketten 'um' die Zeilennummer
' herum definieren.
'
' Werden zwei Dateien übergeben, wird ein Datei-Vergleich
' angeboten, wobei das Skript die Zeilennummern für den
' Dateivergleich auf alles Neunen (z.B. 999) setzt.
'
'************************************************************
Option Explicit
Dim SendToLink : SendToLink = "Sicherung"
Dim ShellLink, Txt, Tst, i, d, v
Dim FileIn, TestMode, ZielVerz, ZeilNr, ZNrSich
v = 0 : Redim Preserve DateiType( 3, v )
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim oArgs : Set oArgs = Wscript.Arguments
Txt = Len( fso.GetExtensionName( WScript.ScriptFullName ) ) ' : MsgBox Txt, , "047 :: "
Txt = Mid( WScript.ScriptName, 1, Len( WScript.ScriptName ) - Txt ) & "dat" ' : MsgBox Txt, , "048 :: "
Dim ParamDatei : ParamDatei = WshShell.Environment("PROCESS")("APPDATA") & "\" & Txt ' : MsgBox Txt, , "049 :: " ' : WScript.Quit
Dim PopUpDauer : PopUpDauer = 3
Dim MaxVerzInh : MaxVerzInh = 3
Dim KopieVerz, ZielDatei, DateiVergl
If InStr( UCase( WScript.ScriptFullName ), "DIESEYER.DE" ) = 0 Then SkriptInfo ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
If oArgs.Count = 1 then
Txt = Left( UCase(oArgs.item(0)), 2)
if Txt = "-S" OR Txt = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf mit WScript.Quit
End If
If not oArgs.Count > 0 then SkriptInfo ' SUB Aufruf mit WScript.Quit
' hole alle Argumente
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
d = 0 : v = 0
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
If fso.FolderExists( oArgs.item(i) ) Then
ReDim Preserve Verz( v )
Verz( v ) = oArgs.item(i)
Txt = Txt & vbCRLF & "084 :: Verz:" & vbTab & Verz( v ) ' : MsgBox Verz( v ) , , "084 :: "
v = v + 1
End If
If fso.FileExists( oArgs.item(i) ) Then
ReDim Preserve Datei( d )
Datei( d ) = oArgs.item(i)
Txt = Txt & vbCRLF & "090 :: Datei:" & vbTab & Datei( d ) ' : MsgBox Datei( d ) , , "090 :: "
d = d + 1
End If
Next
' MsgBox Txt, , "094 :: "
' Wurden zwei Dateien übergeben, "DateiVergl = True" setzen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DateiVergl = False
If UBound( Datei ) = 1 Then DateiVergl = True ' : MsgBox "DateiVergl = " & DateiVergl & vbCRLF & "UBound( Datei ) = " & UBound( Datei ), , "100 :: "
If d = 0 And v = 0 Then SkriptInfo ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~
' Parameterdatei 'ParamDatei' prüfen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not fso.FileExists( ParamDatei ) Then Call ParamFehlt( ParamDatei )
' Parameterdatei 'ParamDatei' lesen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ParamLesen( ParamDatei )
' Existiert Zielverzeichnis für Datensicherung?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
If fso.FolderExists( ZielVerz ) Then Exit Do
MsgBox "Zielverzeichnis " & vbCRLF & vbTab & ZielVerz & vbCRLF & "prüfen!", , "120 :: " : WshShell.Run "notepad " & ParamDatei, , True
Call ParamLesen( ParamDatei )
Loop
' Existiert Kopieverzeichnis für Datensicherung?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
If Len( KopieVerz ) < 4 Then Exit Do
If fso.FolderExists( KopieVerz ) Then Exit Do
MsgBox "KopieVerzeichnis " & vbCRLF & vbTab & KopieVerz & vbCRLF & "prüfen!", , "129 :: " : WshShell.Run "notepad " & ParamDatei, , True
Call ParamLesen( ParamDatei )
Loop
' MsgBox "ParamDatei: " & ParamDatei & vbCRLF & "ZielVerz: " & ZielVerz & vbCRLF & "ZeilNr: " & ZeilNr & vbCRLF & "ZNrSich: " & ZNrSich, , "133 :: " & WScript.ScriptName
' Dateien sichern
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not DateiVergl = True Then
For i = LBound( Datei ) To UBound( Datei )
Call SichDatei( Datei( i ) ) ' SichDatei() mit Call ZeilenAnpassg()
Next
End If
' Dateienvergleich - wenn zwei übergeben wurden
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If DateiVergl = True Then Call DateienVergleich( Datei( 0 ), Datei( 1 ) ) ' DateienVergleich() mit Call ZeilenAnpassg()
' Zielverzeichnis-Größe testen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = fso.GetFolder( ZielVerz ).Size / 1024 / 1024 ' : MsgBox "ZielVerz: " & ZielVerz & vbCRLF & Tst & " MB", , "152 :: "
Tst = CLng( Tst )
MaxVerzInh = CLng( MaxVerzInh ) ' : MsgBox "Verz.Größe: " & Tst & vbCRLF & "MaxVerzInh: " & MaxVerzInh, , "154 :: " & WScript.ScriptName
If Tst < MaxVerzInh Then WScript.Quit
Txt = "Im Sicherungsverzeichnis befinden sich mehr als" & vbCRLF
Txt = Txt & vbTab & Tst & " MB" & vbCRLF
Txt = Txt & "Dateien - vielleicht sollte man 'etwas' löschen?" & vbCRLF & vbCRLF
Txt = Txt & "[Yes]" & vbTab & "Öffnet das Sicherungsverzeichnis." & vbCRLF
Txt = Txt & "[No]" & vbTab & "Öffnet die Parameterdatei"
Tst = WSHShell.Popup( Txt, 10, "163 :: " & WScript.ScriptName, 4096+32+3 )
If Tst = vbCancel Then : WScript.Quit
If Tst = vbYes Then WshShell.Run ZielVerz : WScript.Quit
If Tst <> vbNo Then : WScript.Quit
Call ParamLesen( ParamDatei )
Call ParamFehlt( ParamDatei )
WshShell.Run "notepad " & ParamDatei, , True
' If Tst = vbNo Then WshShell.Run "notepad """ & ParamDatei & """"
WScript.Quit
'***************************************************************
' ENDE - das eigentliche Skript endet
'***************************************************************
'***************************************************************
Sub SkriptInfo ' Sub Aufruf
'***************************************************************
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss über 'Senden an' angesprochen werden," & vbCRLF
Txt = Txt & "um Dateien an das Skript übergeben zu können." & vbCRLF & vbCRLF
Txt = Txt & "" & vbCRLF
Txt = Txt & "[ja]" & vbTab & vbTab & "Skript für 'Senden an' (SendTo) einrichten." & vbCRLF
Txt = Txt & "[nein]" & vbTab & vbTab & "Eine Parameterdatei (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
Txt = WSHShell.Popup (Txt , 30, "195 :: " & WScript.ScriptName, 4096 + 512 + 32 + 3 )
If vbCancel = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "197 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
If vbNo = Txt Then
Call ParamLesen( ParamDatei )
Call ParamFehlt( ParamDatei )
WshShell.Run "notepad " & ParamDatei, , True
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "205 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
If not vbYes = Txt Then
WSHShell.Popup " . . . dann eben nicht!", 10, "210 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End If
Txt = ""
Txt = Txt & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für den " & vbCRLF
Txt = Txt & "angemeldeten Benutzer unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Txt = Txt & "Es ist dann als '" & SendToLink & "' verfügbar." & vbCRLF & vbCRLF
Txt = Txt & "Soll gleich die Parameterdatei angepasst werden?"
Txt = WSHShell.Popup( Txt, , "220 :: " & WScript.ScriptName , 64 + 32 + 4 )
If not Txt = vbYes Then AutoStartLink ( SendToLink ) ' SUB Aufruf mit WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Parameterdatei 'ParamDatei' lesen um Parameter auszulesen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FileExists( ParamDatei ) Then Call ParamLesen( ParamDatei )
WScript.Sleep 500
' Parameterdatei 'ParamDatei' mit Parameter neu schreiben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ParamFehlt( ParamDatei )
' Parameterdatei 'ParamDatei' zum Editieren öffnen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WshShell.Run "notepad " & ParamDatei, , True
AutoStartLink ( SendToLink ) ' SUB Aufruf mit WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Txt, TxtX, 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
Txt = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TxtX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Txt & "PROGRAM FILES" ) then TxtX = Txt & "PROGRAM FILES"
if fso.FolderExists( Txt & "programme" ) then TxtX = Txt & "programme"
TxtX = TxtX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TxtX ) then fso.CreateFolder( TxtX )
On Error GoTo 0
if not fso.FolderExists( TxtX ) then
WSHShell.Popup TxtX & " konnte nicht angelegt werden!" , 30, "273 :: " & WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' Link zur Parameterdatei 'ParamDatei' neben das Skript schreiben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call LinkErstellen( TxtX, ParamDatei ) ' : MsgBox TxtX & vbCRLF & ParamDatei, , "279 :: " : WScript.Quit
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' TxtX = TxtX & "\" & SendToLink & ".vbs"
TxtX = TxtX & "\" & WScript.Scriptname
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
' laufende, Skript ist:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not LCase(TxtX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.GetFile( TxtX ).attributes = 0
err.Clear
WScript.Sleep 333
fso.CopyFile WScript.ScriptFullName, TxtX , True
if not err.number = 0 then
WSHShell.Popup TxtX & " konnte nicht angelegt werden!" & vbCRLF & vbCRLF & err.Number & " - " & err.Description, 30, "297 :: " & 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
Txt = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Txt = "\" & SendToLink & ".lnk" then ' bei Win9x
Txt = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Txt)
ShellLink.TargetPath = TxtX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TxtX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Txt & " konnte nicht angelegt werden!" , 30, "324 :: " & WScript.ScriptName , 64
End If
Txt = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Txt)
ShellLink.TargetPath = TxtX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TxtX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Txt ) then
' WSHShell.Popup Txt & " wird überschrieben!" , 10, "337 :: " & WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Txt & " wurde überschrieben!" , 10, "341 :: " & WScript.ScriptName , 64
Else
WSHShell.Popup Txt & " konnte nicht überschrieben werden!" , 30, "343 :: " & WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Txt & " wurde angelegt!" , 10, "349 :: " & WScript.ScriptName , 64
Else
WSHShell.Popup Txt & " konnte nicht angelegt werden!" , 30, "351 :: " & WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
Function ParamFehlt( ParamDatei )
'***************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, FileOut
Txt = Txt & vbTab & "Es fehlt die Parameterdatei" & vbCRLF & vbCRLF & ParamDatei & vbCRLF & vbCRLF
Txt = Txt & vbTab & "Diese enthält u.a. das zu verwendende Sicherungsverzeichnis . . . und wird jetzt angelegt:" & vbCRLF
If not fso.FileExists( ParamDatei ) Then MsgBox Txt, , "370 :: " & WScript.ScriptName
On Error Resume Next
FSO.OpenTextFile ParamDatei , 2, true ' Datei zum Screiben öffnen; 2: immer neu anlegen
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 5 Then
Txt = "! ! ! F E H L E R ! ! !" & vbCRLF & vbCRLF
Txt = Txt & "Keine Recht zum Schreiben von" & vbCRLF & vbCRLF & vbTab & ParamDatei & vbCRLF & vbCRLF
Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Tst & " . . . Skriptende!"
MsgBox Txt, , "381 :: " & WScript.ScriptName
WScript.Quit
End If
Set FileOut = FSO.OpenTextFile( ParamDatei , 8, true ) ' Datei zum Screiben öffnen; 2: immer neu anlegen
FileOut.WriteLine "; Folgende Parameter müssen angegeben werden, damit das Skript"
' FileOut.WriteLine ";" & vbTab & WScript.ScriptFullName
FileOut.WriteLine ";" & vbTab & WScript.ScriptName
FileOut.WriteLine "; 'vernüftig' arbeiten kann:"
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Schaltet das Skript 'scharf'"
FileOut.WriteLine "; ""TestMode=no"" schaltet den TestMode aus - Kleinbuchstaben!."
FileOut.WriteLine "; Im TestMode wird die Datei mit den angepassten Zeilennummern"
FileOut.WriteLine "; unter einem anderen Namen gespeichert und mit Notepad angezeigt,"
FileOut.WriteLine "; als 'Vertrauensbildende Maßnahme' . . . ;-) "
FileOut.WriteLine "TestMode=" ' & TestMode
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Bei der Übergabe von _zwei_ Dateien werden die Zeilenummern durch"
FileOut.WriteLine "; '999' ersezt und ein Vergleich der beiden Dateien angeboten."
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; ZielVerz=\\mein-pc\c$\Backup\"
FileOut.WriteLine "; ZielVerz=d:\temp"
FileOut.WriteLine "; nicht erlaubt: ZielVerz=X:\"
FileOut.WriteLine "; nicht erlaubt: ZielVerz=Z:"
FileOut.WriteLine "ZielVerz=" & ZielVerz
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; KopieVerz=\\mein-pc\c$\Kopie.en\"
FileOut.WriteLine "; KopieVerz=d:\SicherIstSicher"
FileOut.WriteLine "; nicht erlaubt: KopieVerz=X:\"
FileOut.WriteLine "; nicht erlaubt: KopieVerz=Z:"
FileOut.WriteLine "; Kopie wird nicht erstellt, wenn nicht angegeben: KopieVerz="
FileOut.WriteLine "KopieVerz=" & KopieVerz
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; ZeilNr=1 => Anpassen der Zeilennummern - "
FileOut.WriteLine "; dafür wird aufgerufen: ""Sub ZeilenAnpassg( Datei, ZeichenVor, ZeichenNach )"" "
FileOut.WriteLine "ZeilNr=" & ZeilNr
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; ZNrSich=0 => Die Sicherung wird _vor_ dem Aktualisieren der Zeilennummern erstellt."
FileOut.WriteLine "; ZNrSich=1 => Die Sicherung wird _nach_ dem Aktualisieren der Zeilennummern erstellt."
FileOut.WriteLine "ZNrSich=" & ZNrSich
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Nach erfolgter Sicherung wird eine Meldung mit"
FileOut.WriteLine "; dem kompletten Pfad der zu sichernden Datei"
FileOut.WriteLine "; dem kompletten Pfad der zu Sicherungsdatei"
FileOut.WriteLine "; angezeigt - wie lange soll diese Anzeige dauern (0 zeigt keine)?"
FileOut.WriteLine "PopUpDauer=" & PopUpDauer
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Wenn das Sicherungsverzeichnis eine bestimmte Größe"
FileOut.WriteLine "; (Größe in MegaByte) überschreitet, soll eine Meldung erscheinen"
FileOut.WriteLine "; MaxVerzInh=0 => NIE eine Meldung"
FileOut.WriteLine "MaxVerzInh=" & MaxVerzInh
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Soll z.B. in .BAT- und .CMD-Dateien in der Zeichenkette"
FileOut.WriteLine "; echo 123 :: ! Wichtige Info ! "
FileOut.WriteLine "; die Zahl 123 in die aktuelle Zeilennummer geändert werden:"
FileOut.WriteLine "; DateiTypeA2=CMD"
FileOut.WriteLine "; DateiTypeB2=BAT"
FileOut.WriteLine "; ZeichenVor2=³echo ³"
FileOut.WriteLine "; ZeichenNach2=³ ::³"
FileOut.WriteLine "; WICHTIG ist die Zahl vor dem =, hier Gruppe eins. "
FileOut.WriteLine "; - ZeichenVor1 und ZeichenNach1 darf keine Zahlen enthalten!"
FileOut.WriteLine "; - ein Leerschritt nach dem 'echo'; Tab ist auch möglich"
FileOut.WriteLine "; - mit einem Leerschritt vor und nach den beiden Doppelpunkten"
FileOut.WriteLine "; - ³ (""hoch 3"" bzw. ""dritte Potenz"") gilt als Begrenzer"
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Soll z.B. in .VBS- und .WSF und .HTA-Dateien in der Zeichenkette"
FileOut.WriteLine "; LogEintrag "" 123 :: ! Wichtige Info ! """
FileOut.WriteLine "; die Zahl 123 in die aktuelle Zeilennummer geändert werden:"
FileOut.WriteLine "; DateiTypeA1=WSF"
FileOut.WriteLine "; DateiTypeB1=vbs"
FileOut.WriteLine "; DateiTypeC1=htA"
FileOut.WriteLine "; ZeichenVor1=³""³"
FileOut.WriteLine "; ZeichenNach1=³ :: ³"
FileOut.WriteLine "; WICHTIG ist die Zahl vor dem =, hier Gruppe zwei. "
FileOut.WriteLine "; - ZeichenVor1 und ZeichenNach1 darf keine Zahlen enthalten!"
FileOut.WriteLine "; - ein Leerschritt nach dem 'echo'; Tab ist auch möglich"
FileOut.WriteLine "; - mit einem Leerschritt vor und nach den beiden Doppelpunkten"
FileOut.WriteLine "; - ³ (""hoch 3"" bzw. ""dritte Potenz"") gilt als Begrenzer"
FileOut.WriteLine vbCRLF
FileOut.WriteLine "; Erst DateiTypen mit '1' dann mit '2' . . ."
FileOut.WriteLine vbCRLF
If Len( DateiType( 1, 0 ) ) < 3 AND UBound( DateiType, 2 ) = 0 Then
FileOut.WriteLine "DateiTypeA1="
FileOut.WriteLine "ZeichenVor1="
FileOut.WriteLine "ZeichenNach1="
FileOut.Close
Set FileOut = nothing
Exit Function
End If
Txt = ""
Tst = ""
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
' Txt = " " : If not TestMode="no" Then Txt = "; " & v
FileOut.WriteLine Txt
If Len( DateiType( 1, v ) ) > 1 Then
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i) ) > 1 Then FileOut.WriteLine "DateiType" & Chr( 65 + i ) & v & "=" & Tst( i)
Next
FileOut.WriteLine "ZeichenVor" & v & "=" & "³" & DateiType( 2, v ) & "³"
FileOut.WriteLine "ZeichenNach" & v & "=" & "³" & DateiType( 3, v ) & "³"
End If
Next
Set FileOut = nothing
End Function ' ParamFehlt( ParamDatei )
'***************************************************************
Function ParamLesen( ParamDatei )
'***************************************************************
Dim FileIn, Txt, Tst,v , i
Set FileIn = FSO.OpenTextFile( ParamDatei, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
Txt = LCase( FileIn.Readline )
If not InStr( Txt, ";" ) = 1 AND Len( Txt ) > 5 Then
Tst = "testmode=" : If InStr( Txt,Tst )=1 Then TestMode = Replace( Txt, Tst, "" ) ' : MsgBox TestMode, , "497 :: "
Tst = "zielverz=" : If InStr( Txt,Tst )=1 Then ZielVerz = Replace( Txt, Tst, "" ) ' : MsgBox ZielVerz, , "498 :: "
Tst = "kopieverz=" : If InStr( Txt,Tst )=1 Then KopieVerz = Replace( Txt, Tst, "" ) ' : MsgBox KopieVerz, , "499 :: "
Tst = "zeilnr=" : If InStr( Txt,Tst )=1 Then ZeilNr = Replace( Txt, Tst, "" ) ' : MsgBox ZeilNr, , "500 :: "
Tst = "znrsich=" : If InStr( Txt,Tst )=1 Then ZNrSich = Replace( Txt, Tst, "" ) ' : MsgBox ZNrSich, , "501 :: "
Tst = "popupdauer=" : If InStr( Txt,Tst )=1 Then PopUpDauer = Replace( Txt, Tst, "" ) ' : MsgBox PopUpDauer, , "502 :: "
Tst = "maxverzinh=" : If InStr( Txt,Tst )=1 Then MaxVerzInh = Replace( Txt, Tst, "" ) ' : MsgBox MaxVerzInh, , "503 :: "
If InStr( Txt,"dateitype" ) = 1 Then
i = 0
Tst = Mid( Txt, InStr( Txt, "=" ) - 1, 1 ) ' das Zeichen vor dem = muss eine Zahl sein
Tst = Int( Tst ) ' das Zeichen vor dem = muss eine Zahl sein
Do
If i = Tst And InStr( Txt, i & "=" ) > 9 Then ' z.B. bei "DateiTypeA1="
v = i : If not v = UBound( DateiType, 2 ) Then ReDim Preserve DateiType( 3, v )
DateiType( 1, v ) = DateiType( 1, v ) & "." & Mid( Txt, InStr( Txt, "=" ) + 1 ) ' : MsgBox "DateiType( 1, " & v & " ) = >" & DateiType( 1, v ) & "<" & vbCRLF, , "512 :: "
End If
i = i + 1 : If i > 9 Then Exit Do ' DateiType-Zuordnungen-Zahl muss einstellig sein
Loop
End If
Txt = Replace( Txt, "³", "" )
Tst = "zeichenvor" : If InStr( Txt,Tst )=1 Then DateiType( 2, v ) = Mid( Txt, InStr( Txt, "=" ) + 1 ) ' : MsgBox PopUpDauer, , "519 :: "
Tst = "zeichennach" : If InStr( Txt,Tst )=1 Then DateiType( 3, v ) = Mid( Txt, InStr( Txt, "=" ) + 1 ) ' : MsgBox PopUpDauer, , "520 :: "
End If
Tst = ""
Tst = Tst & "DateiType( 1, " & v & " ) = >" & DateiType( 1, v ) & "<" & vbCRLF
Tst = Tst & "ZeichenVor = >" & DateiType( 2, v ) & "<" & vbCRLF
Tst = Tst & "ZeichanNach = >" & DateiType( 3, v ) & "<" & vbCRLF
Tst = Replace( Tst, "³", "" ) : Tst = Replace( Tst, vbTab, "vbTab" )
' If Len( DateiType( 1, v ) ) > 2 Then MsgBox Tst & Txt, , "527 :: "
' If Len( Txt ) < 2 And Len( DateiType( 1, v ) ) > 2 Then MsgBox Tst & Txt, , "528 :: "
Loop
FileIn.Close
Set FileIn = nothing
If ZeilNr = "" Then ZeilNr = 0
If ZNrSich = "" Then ZNrSich = 0
If PopUpDauer = "" Then PopUpDauer = 3
' MsgBox "TestMode: " & TestMode & vbCRLF & "ParamDatei: " & ParamDatei & vbCRLF & "ZielVerz: " & ZielVerz & vbCRLF & "ZeilNr: " & ZeilNr & vbCRLF & "ZNrSich: " & ZNrSich, , "537 :: " & WScript.ScriptName
' WScript.Quit
End Function ' ParamLesen( ParamDatei )
'***************************************************************
Function SichDatei( DateiName )
'***************************************************************
Dim Txt, Tst, Tst1, Tst2, i, n, x
Txt = DateiName
Txt = Replace( Txt, "\", "³" )
Txt = Replace( Txt, ":", "" )
' MsgBox InStrrev( ZielVerz, "\" ) & vbCRLF & Len( ZielVerz ), , "550 :: "
' Falls vorhanden, letztes "\" abschneiden
If InStrrev( ZielVerz, "\" ) = Len( ZielVerz ) Then ZielVerz = Mid( ZielVerz, 1, Len( ZielVerz ) - 1 )
If InStrrev( KopieVerz, "\" ) = Len( KopieVerz ) Then KopieVerz = Mid( KopieVerz, 1, Len( KopieVerz ) - 1 )
KopieVerz = KopieVerz & "\"
On Error Resume Next
If Len( KopieVerz ) > 3 Then fso.CopyFile DateiName, KopieVerz, True
On Error GoTo 0
Txt = ZielVerz & "\" & Txt
Tst2 = fso.GetExtensionName( Txt ) ' nur die Dateierweiterung
Tst1 = Len( fso.GetExtensionName( Txt ) ) ' Anz. der Zeichen der Dateierweiterung
Tst1 = Mid( Txt, 1, Len( Txt ) - Tst1 -1 ) ' Datei ohne Dateierweiterung
x = " 000."
Txt = Tst1 & x & Tst2 ' : MsgBox Txt, , "566 :: "
Do ' freie Nummer für Dateisicherung ermitteln
If not fso.FileExists( Txt ) Then Exit Do
n = n + 1 : x = n
If Len( x ) < 3 Then x = "0" & x
If Len( x ) < 3 Then x = "0" & x
x = " " & x & "."
Txt = Tst1 & x & Tst2 ' neue Nummer für Dateisicherung
' MsgBox Txt, , "575 :: "
Wscript.Sleep 1
Loop
ZielDatei = Txt
' Sicherung ohne Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not ZeilNr=1 Then
fso.CopyFile DateiName, ZielDatei
If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & ZielDatei & vbCRLF & vbTab & "DateiName: " & DateiName, PopUpDauer, "587 :: " & WScript.ScriptName, 4096+64
Exit Function
End If
' Sicherung vor Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not ZNrSich=1 Then
fso.CopyFile DateiName, ZielDatei
If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich (vor Anpassen der Zeilennr.) kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & vbCRLF & ZielDatei & vbCRLF & vbTab & "DateiName: " & vbCRLF & DateiName, PopUpDauer, "596 :: " & WScript.ScriptName, 4096+64
End If
' Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = LCase( fso.GetExtensionName( DateiName ) ) ' Dateityp ermitteln
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
If Len( DateiType( 1, v ) ) > 1 Then ' die unterstüzten DateiTypen ermittel
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i ) ) > 1 Then ' die DateiTyp mit unterstüzten DateiTypen vergleichen
If LCase( Tst( i ) ) = Txt Then Call ZeilenAnpassg( DateiName, DateiType( 2, v ), DateiType( 3, v ) )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~_____________~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End If
Next
End If
Next
On Error Resume Next
If Len( KopieVerz ) > 3 Then fso.CopyFile DateiName, KopieVerz, True
On Error GoTo 0
' Sicherung (erfolgte bereits) vor Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not ZNrSich=1 Then
' If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich (vor Anpassen der Zeilennr.) kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & vbCRLF & ZielDatei & vbCRLF & vbTab & "DateiName: " & vbCRLF & DateiName, PopUpDauer, "622 :: " & WScript.ScriptName, 4096+64
Exit Function
End If
' Sicherung nach Anpassung der Zeilennummer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fso.CopyFile DateiName, ZielDatei
If PopUpDauer > 0 Then WSHShell.Popup "Erfolgreich (nach Anpassen der Zeilennr.) kopiert:" & vbCRLF & vbCRLF & vbTab & "ZielDatei: " & vbCRLF & ZielDatei & vbCRLF & vbTab & "DateiName: " & vbCRLF & DateiName, PopUpDauer, "630 :: " & WScript.ScriptName, 4096+64
End Function ' SichDatei( DateiName )
'***************************************************************
Sub ZeilenAnpassg( Datei, ZeichenVor, ZeichenNach )
'***************************************************************
' Von der 'Datei' wird keine Sicherung erstellt - 'Datei' wird komplett eingelesen
' und anschließend mit korregierten Zeilennummern beim Schreiben überschrieben.
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim ZeileTxt, Txt, Tst, Ttt, Tyt, Tzt, Tut, i, n, PC
Dim FileOut, FileIn
Dim TestWeiter : TestWeiter = True
Dim VorNachGleich : VorNachGleich = True ' Vorher-Nachher-Vergleich; VorNachGleich = False wenn min. eine Zeilennumer geändert wurde
' MsgBox "Sub ZeilenAnpassg( " & Datei & ", " & ZeichenVor & ", " & ZeichenNach & " )" & vbCRLF & "DateiVergl: " & DateiVergl , , "647 :: "
' 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
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
i = i + 1
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen/anpassen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
Txt = Zeile(i) : ZeileTxt = Zeile(i) ' Zeile merken für Vorher-Nachher-Vergleich
If InStr( Txt, ZeichenVor ) > 0 AND InStr( Txt, ZeichenNach ) > 0 Then
Zeile(i) = "" ' leeren
Tst = ""
' Zeile zerlegen
Tst = Split( Txt, ZeichenNach )
' Tut = i + 1 & vbTab & UBound( Tst ) & vbCRLF
' For n = LBound( Tst ) to UBound( Tst )
' Tut = Tut & n & vbTab & Tst( n ) & vbCRLF
' Next
Txt = "Vor" & vbTab & Txt & vbCRLF & "ZeichenVor:" & vbTab & ZeichenVor & vbCRLF & "ZeichenNach:" & vbTab & ZeichenNach & vbCRLF & "===> " & i + 1 & ". Zeile . . . "
For n = LBound( Tst ) to UBound( Tst )
' MsgBox "Zeile( " & i+1 & " ) wird bearbeitet", 4096, "682 :: " ' : WScript.Quit
' MsgBox "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "685 :: " ' : WScript.Quit
If InStrRev( Tst( n ), ZeichenVor ) > 0 AND n <> UBound( Tst ) AND Len( Tst ( n ) ) > Len( ZeichenVor ) + 1 Then
' MsgBox "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "687 :: " ' : WScript.Quit
Ttt = InStrRev( Tst( n ), ZeichenVor ) ' Ttt = Anzahl Zeichen _vor_ 'ZeichenVor'
Ttt = Ttt + Len( ZeichenVor ) ' Ttt = muss Position der ersten Zahl zwischen 'ZeichenVor' und 'ZeichenNach' enthalten
Do
' Zahlen entfernen bzw. Suche der Stelle nach der letzten Ziffer in der alten Zeilennummer
If IsNumeric( Mid( Tst( n ), Ttt, 1 ) ) = False Then Exit Do
Ttt = Ttt + 1 ' : MsgBox "Zeile( " & i+1 & " ) = " & Zeile(i) & vbCRLF & "erste Zahl>>>" & Mid( Tst( n ), Ttt ) & vbCRLF , 4096, "694 :: " : WScript.Quit
Loop
' MsgBox "Ttt - 1 = " & Ttt - 1 & vbCRLF & "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "697 :: " ' : WScript.Quit
If Len( Tst( n ) ) = Ttt - 1 Then ' Ttt muss das Ende von Tst( n ) erreicht haben
Tzt = Len( UBound( Zeile ) ) ' Anzahl der Stellen für die neue Zeilennummer
Tyt = i + 1 : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt : If Len( Tyt ) < Tzt Then Tyt = "0" & Tyt
' neue Zeilennumer ist gebildet
If DateiVergl = True Then Tyt = String( Tzt, "9" ) ' : MsgBox "Tyt: >" & Tyt & "<", , "704 :: "
' Wenn ein Dateivergleich durchgeführt werden soll, wird die Zeilennummer nur '9' enthalten
' MsgBox "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), , "707 :: " : : WScript.Quit
Tst( n ) = Left( Tst( n ), InStrRev( Tst( n ), ZeichenVor ) + Len( ZeichenVor ) - 1 )
' die Zeichen vor der Zeilennummer
Tst( n ) = Tst( n ) & Tyt ' die neue Zeilennummer
Tst( n ) = Tst( n ) & ZeichenNach ' in Tst(n) fehlt 'ZeichenNach'
Else
Tst( n ) = Tst( n ) & ZeichenNach ' in Tst(n) fehlt 'ZeichenNach'
End If
Else
' MsgBox "Len( """ & ZeichenVor & """ ) + 2 = " & Len( ZeichenVor ) + 2 & vbCRLF & "InStrRev( Tst( " & n+1 & " ), """ & ZeichenVor & """ ) = " & InStrRev( Tst( n ), ZeichenVor ) & vbCRLF & "Len( Tst( " & n & " ) ) = " & Len( Tst( n ) ) & vbCRLF & "Ttt = " & Ttt & vbCRLF & "Tst( " & n & " ) = " & Tst( n ), 4096, "717 :: " ' : WScript.Quit
If n <> UBound( Tst ) Then Tst( n ) = Tst( n ) & ZeichenNach ' in Tst(n) fehlt 'ZeichenNach'
End If
Zeile(i) = Zeile(i) & Tst( n )
If TestMode="-no" Then Txt = Txt & vbCRLF & n & vbTab & "Ttt = " & Ttt & vbCRLF & n & vbTab & ">" & Tst( n ) & "< ___ " & Len( Tst(n ) )
Next
' MsgBox Zeile(i) & vbCRLF & Txt , 4096, "726 :: " ' : WScript.Quit
If not TestMode="no" AND TestWeiter = True Then Txt = MsgBox( "Nach" & vbTab & Zeile(i) & vbCRLF & Txt & vbCRLF & "Datei: " & vbTab & Datei, 4096 + 1, "727 :: " )' : WScript.Quit
If not Txt = vbOK Then TestWeiter = False
Else
Txt = ""
Txt = Txt & "ZeichenVor: " & vbTab & ZeichenVor & vbCRLF & "Pos.ZeichenVor: " & vbTab & InStr( Txt, ZeichenVor ) & vbCRLF
Txt = Txt & "ZeichenNach: " & vbTab & ZeichenNach & vbCRLF & "Pos.ZeichenNach: " & vbTab & InStr( Txt, ZeichenNach ) & vbCRLF
' If InStr( Zeile(i) , "TstZeile" ) > 0 Then MsgBox i + 1 & vbCRLF & Zeile(i) & vbCRLF & vbCRLF & Txt, 4096, "733 :: " ' : WScript.Quit
End If
If ZeileTxt <> Zeile(i) Then VorNachGleich = False ' die Zeilennummer wurde angepasst
Next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not TestMode = "no" Then Datei = Datei & ".txt"
If VorNachGleich = False OR not TestMode="no" Then
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
for i = 0 to UBound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOuT = nothing
Else
WSHShell.Popup Datei & vbCRLF & vbCRLF & vbTab & "wurde unverändert gesichert.", 3, "753 :: " & WScript.ScriptName , 4096
End If
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not TestMode="no" Then WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepad) beendet ist
If Datei = WScript.ScriptFullName Then WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepad) beendet ist
End Sub ' ZeilenAnpassg( Datei, ZeichenVor, ZeichenNach )
'***************************************************************
Sub DateienVergleich( Datei1, Datei2 )
'***************************************************************
' angepasst aus "dateienvergleich.vbs" v3.B
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim Txt, Tst
Txt = vbTab & "Die Dateien " & vbCRLF & vbCRLF
Txt = Txt & Datei1 & vbCRLF
Txt = Txt & Datei2 & vbCRLF & vbCRLF
Txt = Txt & vbTab & "werden jetzt BINÄR verglichen." & vbCRLF & vbCRLF
Txt = Txt & ". . . oder reicht ein Txt -Vergleich? [Yes] in 5 sec."
Txt = WSHShell.Popup (Txt, 10, "778 :: " & WScript.ScriptName , 4096+32+3 )
If Txt = vbCancel then
WSHShell.Popup " . . . dann eben nicht!", 10, "780 :: " & WScript.ScriptName , 48
Exit Sub ' WScript.Quit
End If
' die beiden Dateien nach %Temp% kopieren
Tst = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & fso.GetFileName( Datei1 )
Txt = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & fso.GetFileName( Datei2 )
fso.CopyFile Datei1, Tst, True : Datei1 = Tst
fso.CopyFile Datei2, Txt, True : Datei2 = Txt
' Anpassung der Zeilennummer: Datei1
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = LCase( fso.GetExtensionName( Datei1 ) ) ' Dateityp ermitteln
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
If Len( DateiType( 1, v ) ) > 1 Then ' die unterstüzten DateiTypen ermittel
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i ) ) > 1 Then ' die DateiTyp mit unterstüzten DateiTypen vergleichen
If LCase( Tst( i ) ) = Txt Then Call ZeilenAnpassg( Datei1, DateiType( 2, v ), DateiType( 3, v ) )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~_____________~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End If
Next
End If
Next
' Anpassung der Zeilennummer: Datei2
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = LCase( fso.GetExtensionName( Datei2 ) ) ' Dateityp ermitteln
For v = LBound( DateiType, 2 ) to UBound( DateiType, 2 )
If Len( DateiType( 1, v ) ) > 1 Then ' die unterstüzten DateiTypen ermittel
Tst = Split( DateiType( 1, v ), "." )
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst( i ) ) > 1 Then ' die DateiTyp mit unterstüzten DateiTypen vergleichen
If LCase( Tst( i ) ) = Txt Then Call ZeilenAnpassg( Datei2, DateiType( 2, v ), DateiType( 3, v ) )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~_____________~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End If
Next
End If
Next
Tst = "%comspec% /c fc /N /L" ' Vergleichmodus 'ASCII'
If Txt = vbNo then Tst = "%comspec% /c fc /B " ' Vergleichmodus 'binär'
Txt = WScript.ScriptFullName & ".txt" ' temp. Zieldatei
Txt = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & WScript.ScriptName & ".tmp" ' temp. Zieldatei
Tst = Tst & " """ & Datei1 & """ """ & Datei2 & """ > """ & Txt & """ " :' MsgBox Tst, , "827 :: "
WSHShell.run Tst , 7, True
' WScript.Sleep 3*1000
fso.DeleteFile Datei1, True
fso.DeleteFile Datei2, True
Tst = "notepad " & Txt
WSHShell.run Tst , , True
End Sub ' DateienVergleich( Datei1, Datei2 )
'*** v9.5 *** www.dieseyer.de *******************************
Sub LinkErstellen( LinkPfad, Ziel )
'***********************************************************
Dim LinkNeu, Tst
Tst = LinkPfad & Mid( Ziel, InStrRev( Ziel, "\" ) ) & ".lnk" ' Dateiname des Links
Set LinkNeu = CreateObject("WScript.Shell").CreateShortcut( Tst )
' LinkNeu.Arguments = "1 2 3"
LinkNeu.Description = Ziel
' LinkNeu.HotKey = "CTRL+ALT+SHIFT+X"
LinkNeu.IconLocation = "%SystemRoot%\system32\SHELL32.dll,1"
LinkNeu.TargetPath = Ziel
LinkNeu.WindowStyle = 3
LinkNeu.WorkingDirectory = Mid( Ziel, 1, InStrRev( Ziel, "\" ) )
LinkNeu.Save
Set LinkNeu = nothing
End Sub ' LinkErstellen( Ziel )
#########################################################################
>>> shell32dllversion.vbs <<<
'v3.B**********************************************************
' File: SHELL32DLLversion.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Siehe WinFAQ.de - nach 'Active Desktop' suchen.
'**************************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' Betriebssystem ermitteln ( WinNT/2k/XP oder Win9x/ME ); siehe Zeilenende ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
Text = "\system32"
If not "Windows_NT" = WScript.CreateObject("WScript.Shell").Environment("Process")("OS") then Text = "\system"
Text = WSHShell.ExpandEnvironmentStrings("%WinDir%") & Text & "\shell32.dll"
MsgBox UCASE( Text) & vbCRLF & "hat die Version: " & fso.GetFileVersion( text ), , WScript.ScriptName
#########################################################################
>>> shellapplicationnamespace.vbs <<<
'*** v9.6 *** www.dieseyer.de ******************************
'
' Datei: ShellApplicationNamespace.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Sub-Prozedur
' ShellApplicationNamespace( )
' ermittel alle verfügbaren 'Umgebungsparameter'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, Tst, i
' Alle gesetzten 'NameSpace' anzeigen (Sucbegriff ist leer)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = WScript.ScriptFullName & ".txt"
Txt = ShellApplicationNamespace( "" )
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Tst, 2, true ).WriteLine ( Txt )
WScript.CreateObject("WScript.Shell").Run "notepad """ & Tst & """"
' Alle 'NameSpace' anzeigen, die Sucbegriff enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MsgBox ShellApplicationNamespace( "start" ), , "21 :: " & WScript.ScriptName
' Pfad zu einem 'NameSpace' anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 24
Txt = CreateObject("Shell.Application").Namespace( i ).Self.Name
Txt = Txt & vbCRLF & CreateObject("Shell.Application").Namespace( i ).Self.Path
MsgBox vbTab & i & vbCRLF & Txt, , "28 :: " & WScript.ScriptName
' Pfad zu einem 'NameSpace' anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 6
Txt = CreateObject("Shell.Application").Namespace( 6 ).Self.Path
MsgBox vbTab & i & vbCRLF & Txt, , "28 :: " & WScript.ScriptName
WScript.Quit
'*** v9.5 *** www.dieseyer.de ******************************
Function ShellApplicationNamespace( Txt )
'***********************************************************
Txt = LCase( Txt )
Dim objShell : Set objShell = CreateObject("Shell.Application")
Dim Tst, Tyt, i
i = 0
Do
Tyt = ""
On Error Resume Next
Tyt = i & ": " & vbTab & objShell.Namespace( i ).Self.Name & vbTab & objShell.Namespace( i ).Self.Path
On Error Goto 0
If InStr( LCase( Tyt ), Txt ) > 0 Then Tst = Tst & Tyt & vbCRLF ' nur Zeilen mit ...
i = i + 1 : If i > 255 Then Exit Do
' If Len( Tst ) > 800 Then MsgBox Tst : Tst = ""
Loop
ShellApplicationNamespace = Tst
End Function ' ShellApplicationNamespace()
' 0: Desktop C:\Dokumente und Einstellungen\[AngemeldeterUser]\Desktop
' 1: Internet Explorer ::{871C5380-42A0-1069-A2EA-08002B30309D}
' 2: Programme C:\Dokumente und Einstellungen\[AngemeldeterUser]\Startmenü\Programme
' 3: Systemsteuerung ::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}
' 4: Drucker und Faxgeräte ::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{2227A280-3AEA-1069-A2DE-08002B30309D}
' 5: Eigene Dateien D:\EigeneDateien
' 6: Favoriten C:\Dokumente und Einstellungen\[AngemeldeterUser]\Favoriten
' 7: Autostart C:\Dokumente und Einstellungen\[AngemeldeterUser]\Startmenü\Programme\Autostart
' 8: Zuletzt verwendete Dokumente C:\Dokumente und Einstellungen\[AngemeldeterUser]\Recent
' 9: SendTo C:\Dokumente und Einstellungen\[AngemeldeterUser]\SendTo
' 10: Papierkorb ::{645FF040-5081-101B-9F08-00AA002F954E}
' 11: Startmenü C:\Dokumente und Einstellungen\[AngemeldeterUser]\Startmenü
' 13: Eigene Musik D:\EigeneDateien\Eigene Musik
' 14: Eigene Videos D:\EigeneDateien\Eigene Videos
' 16: Desktop C:\Dokumente und Einstellungen\[AngemeldeterUser]\Desktop
' 17: Arbeitsplatz ::{20D04FE0-3AEA-1069-A2D8-08002B30309D}
' 18: Netzwerkumgebung ::{208D2C60-3AEA-1069-A2D7-08002B30309D}
' 19: Netzwerkumgebung C:\Dokumente und Einstellungen\[AngemeldeterUser]\Netzwerkumgebung
' 20: Fonts C:\WINDOWS\Fonts
' 21: Vorlagen C:\Dokumente und Einstellungen\[AngemeldeterUser]\Vorlagen
' 22: Startmenü C:\Dokumente und Einstellungen\All Users\Startmenü
' 23: Programme C:\Dokumente und Einstellungen\All Users\Startmenü\Programme
' 24: Autostart C:\Dokumente und Einstellungen\All Users\Startmenü\Programme\Autostart
' 25: Desktop C:\Dokumente und Einstellungen\All Users\Desktop
' 26: Anwendungsdaten C:\Dokumente und Einstellungen\[AngemeldeterUser]\Anwendungsdaten
' 27: Druckumgebung C:\Dokumente und Einstellungen\[AngemeldeterUser]\Druckumgebung
' 28: Anwendungsdaten C:\Dokumente und Einstellungen\[AngemeldeterUser]\Lokale Einstellungen\Anwendungsdaten
' 31: Favoriten C:\Dokumente und Einstellungen\All Users\Favoriten
' 32: Temporary Internet Files C:\Dokumente und Einstellungen\[AngemeldeterUser]\Lokale Einstellungen\Temporary Internet Files
' 33: Cookies C:\Dokumente und Einstellungen\[AngemeldeterUser]\Cookies
' 34: Verlauf C:\Dokumente und Einstellungen\[AngemeldeterUser]\Lokale Einstellungen\Verlauf
' 35: Anwendungsdaten C:\Dokumente und Einstellungen\All Users\Anwendungsdaten
' 36: WINDOWS C:\WINDOWS
' 37: system32 C:\WINDOWS\system32
' 38: Programme C:\Programme
' 39: Eigene Bilder D:\EigeneDateien\Eigene Bilder
' 40: [AngemeldeterUser] C:\Dokumente und Einstellungen\[AngemeldeterUser]
' 41: system32 C:\WINDOWS\system32
' 43: Gemeinsame Dateien C:\Programme\Gemeinsame Dateien
' 45: Vorlagen C:\Dokumente und Einstellungen\All Users\Vorlagen
' 46: Gemeinsame Dokumente C:\Dokumente und Einstellungen\All Users\Dokumente
' 47: Verwaltung C:\Dokumente und Einstellungen\All Users\Startmenü\Programme\Verwaltung
' 48: Verwaltung C:\Dokumente und Einstellungen\[AngemeldeterUser]\Startmenü\Programme\Verwaltung
' 49: Netzwerkverbindungen ::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{7007ACC7-3202-11D1-AAD2-00805FC1270E}
' 53: Gemeinsame Musik C:\Dokumente und Einstellungen\All Users\Dokumente\Eigene Musik
' 54: Gemeinsame Bilder C:\Dokumente und Einstellungen\All Users\Dokumente\Eigene Bilder
' 55: Gemeinsame Videos C:\Dokumente und Einstellungen\All Users\Dokumente\Eigene Videos
' 56: Resources C:\WINDOWS\Resources
' 57: 0407 C:\WINDOWS\Resources\0407
' 59: CD Burning C:\Dokumente und Einstellungen\[AngemeldeterUser]\Lokale Einstellungen\Anwendungsdaten\Microsoft\CD Burning
' 61: Workgroup Workgroup
'
#########################################################################
>>> skript-neustarten.vbs <<<
'*** v5.A *** www.dieseyer.de *******************************
'
' Datei: skript-neustarten.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
' Durch eine Prozedur wird geprüft, ob sich das Datei-
' datum geändert hat - wenn ja, startet das (alte) Skript
' das (neue) Skript und (das alte) beendet sich selbst.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogEintrag( "017 :: " & WScript.ScriptFullName & " wird gestartet . . . " )
LogEintrag( "018 :: " & WScript.ScriptFullName & " vom " & WScript.CreateObject("Scripting.FileSystemObject").GetFile( WScript.ScriptFullName ).DateLastModified)
Dim VBSmodTime ' für die Prozedur "Sub VBSneustart()" erforderlich
Dim i
Do
Call VBSbeenden() ' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Call VBSneustart()' Startet dieses Skript neu, wenn sich das Dateidatum geändert hat
i = i + 1
WScript.Sleep 250
Call VBSbeenden() ' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Loop
MsgBox "E N D E", , "035 :: " & WScript.ScriptName
WScript.Quit
'************************************************************
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 )
FileOut.Close
Set FileOut = Nothing
Set fso = Nothing
End Sub ' LogEintrag( LogTxt )
'*** v5.A *** www.dieseyer.de *******************************
Sub VBSbeenden()
'************************************************************
' beendet dieses Skript, wenn es gelöscht oder umbenannt wurde
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
WScript.Sleep 100
On Error Resume Next
If fso.FileExists( WScript.ScriptFullName ) Then Exit Sub
On Error GoTo 0
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
LogEintrag( "085 :: " & WScript.ScriptFullName & " existiert nicht!" )
LogEintrag( "086 :: " & WScript.ScriptFullName & " wird beendet . . . " & vbCRLF )
LogEintrag( "087 :: " & WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . " & vbCRLF )
WScript.CreateObject("WScript.Shell").Popup WScript.ScriptFullName & " wird nach " & i & " Durchläufen beendet . . . " , 30, WScript.ScriptName , 64
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 "117 :: Das Dateidatum von """ & WScript.ScriptName & """ wurde " & VBSmodZahl & "x getestet.", 1
' WSCript.Sleep 1*1000
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "122 :: Das NEUE """ & SelbstVBS & """ wird jetzt gestartet . . . ", 1
WScript.CreateObject("WScript.Shell").Run """" & SelbstVBS & """"
' Prozedur-Aufruf für das Schreiben einer Protokolldatei
Trace32Log "127 :: 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 )
#########################################################################
>>> snapshotsenden.vbs <<<
'*** v10.8 *** www.dieseyer.de *****************************
'
' Datei: snapshotsenden.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim EmailTo : EmailTo = "nichtverwendet@gmx.de"
Dim EmailFrom : EmailFrom = EmailTo
Dim UserName : UserName = EmailTo
Dim UserPwd : UserPwd = "PwdIstGeheim!"
Dim SMTPServer : SMTPServer = "smtp.1und1.de"
: SMTPServer = "mail.gmx.net"
Dim Betreff : Betreff = "Email per SMTP mit Login"
Dim Text : Text = "Ich hoffe, das VBS packt das . . . von " & CreateObject("WScript.Network").ComputerName
Dim Anhang : Anhang = WScript.ScriptFullName ' als Anhang dieses VBS
: Anhang = "" ' kein Anhang'
' CreateObject("WScript.Shell").Run """C:\Program Files\Webcamshot\WEBCAMSHOT.exe"" -s", 0, True
Text = ExecHiddenPlus( "ipconfig /all" )
ExecHiddenPlus """C:\Program Files\Webcamshot\WEBCAMSHOT.exe"" -s"
Anhang = "C:\Users\MA\AppData\Local\VirtualStore\Program Files\Webcamshot\WEBCAMSHOT.jpg"
EmailSenden SMTPServer, EmailFrom, EmailTo, UserName, UserPwd, Betreff, Text, Anhang
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Popup "EMail versendet an " & vbCRLF & vbCRLF & vbTab & EmailTo, 7, "31 :: " & WScript.ScriptName, 4096 + vbInformation
WScript.Quit
'*** v9.A *** www.dieseyer.de ******************************
Sub EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'***********************************************************
' Siehe http://www.microsoft.com/technet/scriptcenter/guide/sas_ent_wbpa.mspx?mfr=true
' Siehe http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1129.mspx
' How Can I Attach a File to an Email Sent Using CDO?
' ==> The Scripting Guys Answer Your Questions
' Dort fehlt:
' .Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
' Sonst kommt:
' 550 must be authenticated
' 550 Need to authenticate
' Siehe http://msdn.microsoft.com/en-us/library/ms526318%28EXCHG.10%29.aspx
Dim objEmail : Set objEmail = CreateObject("CDO.Message")
objEmail.From = EmailVon
objEmail.To = EmailAn
' objEmail.Cc = EmailAn
' objEmail.Bcc = EmailAn
objEmail.Subject = Betreff
objEmail.Textbody = Text
If not Anhang = "" Then
objEmail.AddAttachment Anhang
End If
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")= 1
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = AnmName
objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = AnmPassw
objEmail.Configuration.Fields.Update
On Error Resume Next
Tst = objEmail.Send
' If err.Number <> 0 Then MsgBox err.Number & " - " & err.Description, , "70 :: " & WScript.ScriptName
End Sub ' EmailSenden( SMTPServer, EmailVon, EmailAn, AnmName, AnmPassw, Betreff, Text, Anhang )
'*** v9.4 *** www.dieseyer.de ******************************
Function ExecHiddenPlus( CMD )
'***********************************************************
Dim FileOut, oWsh, Tmp
Tmp = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
If CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
CreateObject("Scripting.FileSystemObject").DeleteFile Tmp, True
End If
If not CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
' zum Test nächste Zeile frei geben
' MsgBox Tmp & vbCRLF & vbCRLF & "F E H L T und wird deshalb neu geschrieben.", , "40 :: " & Titel
Set FileOut = CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = """" " )
FileOut.WriteLine( " set oArgs = Wscript.Arguments " )
FileOut.WriteLine( " For i = 0 to oArgs.Count - 1 " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox oArgs.item(i) , , WScript.ScriptName & "" - oArgs "" " )
FileOut.WriteLine( " if Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & """""""" & oArgs.item(i) & """""""" & "" "" " )
FileOut.WriteLine( " if not Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & oArgs.item(i) & "" "" " )
FileOut.WriteLine( " Next " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox CMD , , WScript.ScriptName & "" Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec( CMD ) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ), , WScript.ScriptName & "" Ende "" " )
FileOut.Close
Set FileOuT = nothing
End If
Set oWsh = CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp & " " & CMD , 0, true
ExecHiddenPlus = oWsh.Environment("Volatile")( "Ergebnis" )
' zum Test nächste Zeile frei geben - Löschen der 'Tmp-Datei
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHiddenPlus( CMD )
#########################################################################
>>> sort-bubblesort.vbs <<<
'*** v3.6 *** www.dieseyer.de *******************************
'
' Datei: sort-bubblesort.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Sortiert die Zeilen einer Datei alphabetisch
'
' Das Sortieren auf einem Pentium 600MHz von
' 10.000 Zeilen VBScript-Code dauert ca. 8 min
' mit 20..30% CPU-Last
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim StartZeit : StartZeit = Timer()
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then Datei = oArgs.item(i)
Next
' Gibt's keinen Dateinamen, werden halt die Zeilen des Skripts
' alphabetisch sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve arrTest(i)
arrTest(i) = FileIn.Readline
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
Text = UBound(arrTest) & " Zeilen der Datei " & Datei & " werden jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert." & vbCRLF
arrSort = bubblesort(arrTest) ' function - Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = Text & UBound(arrTest) & " Zeilen der Datei " & Datei & " sind jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert."
' Zieldatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & ".txt"
' Datei mit sortierten Zeilen füllen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Lesen öffnen
' FileOut.WriteLine( Text & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound(arrTest)
FileOut.WriteLine( i+1 & vbTab & arrTest(i) )
next
' FileOut.WriteLine( vbCRLF & vbCRLF & now() ) ' nur Für Testzwecke
FileOut.Close
Set FileOut = nothing
' Datei mit sortierten Zeilen anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run Datei
MsgBox i & " Zeilen sind nach " & Timer() - StartZeit & "s sortiert.", 4096, WScript.ScriptName
WScript.Sleep 3000
' Datei mit sortierten Zeilen löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile ( Datei )
WScript.Quit
'*** v3.6 *** www.dieseyer.de *******************************
Function bubblesort( arrSortieren )
'************************************************************
Dim i, j
for i = 0 to ubound(arrSortieren)
for j = i + 1 to ubound(arrSortieren)
if UCase( arrSortieren(i) ) > UCase( arrSortieren(j) ) then
' Groß- und Kleinbuchstaben werden gelich behandelt
' -------------------------------------------------
' if arrSortieren(i) > arrSortieren(j) then
' erst alle Zeilen die mit Großbuchstaben beginnen
' dann alle Zeilen die mit Kleinbuchstaben beginnen
' -------------------------------------------------
bubblesort = arrSortieren(i)
arrSortieren(i) = arrSortieren(j)
arrSortieren(j) = bubblesort
end if
next
next
End Function ' bubblesort( arrSortieren )
#########################################################################
>>> sort-heapsort.vbs <<<
'*** v3.6 *** www.dieseyer.de *******************************
'
' Datei: sort-heapsort.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Sortiert die Zeilen einer Datei alphabetisch.
'
' Das Sortieren auf einem Pentium 600MHz von
' 10.000 Zeilen VBScript-Code dauert ca. 2:30 min
' mit 100% CPU-Last
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim StartZeit : StartZeit = Timer()
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then Datei = oArgs.item(i)
Next
' Gibt's keinen Dateinamen, werden halt die Zeilen des Skripts
' alphabetisch sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
Text = Text & now() & vbCRLF
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve arrTest(i)
arrTest(i) = FileIn.Readline
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
Text = UBound(arrTest) & " Zeilen der Datei " & Datei & " werden jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert." & vbCRLF
arrSort = HeapSort ( arrTest )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' arrSort = QuickSort(arrTest, LBound(arrTest), UBound(arrTest))
Text = Text & UBound(arrTest) & " Zeilen der Datei " & Datei & " sind jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert."
' Zieldatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & ".txt"
' Datei mit sortierten Zeilen füllen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Lesen öffnen
' FileOut.WriteLine( Text & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound(arrTest)
FileOut.WriteLine( i+1 & vbTab & arrTest(i) )
next
' FileOut.WriteLine( vbCRLF & vbCRLF & now() ) ' nur Für Testzwecke
Text = Text & now()
FileOut.Close
Set FileOuT = nothing
' Datei mit sortierten Zeilen anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run Datei
MsgBox i & " Zeilen sind nach " & Timer() - StartZeit & "s sortiert.", 4096, WScript.ScriptName
WScript.Sleep 3000
' Datei mit sortierten Zeilen löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile ( Datei )
WScript.Quit
'*** v3.6 *** www.dieseyer.de *******************************
' function QuickSort(vntArray, intVon, intBis) ' funtion Anfang
Function HeapSort(ByRef A)
'************************************************************
' Aus der MS-NG am 13.03.2003 von von Hubert Daubmeier
Dim HeapSize, i
HeapSize = UBound(A) + 1
BuildHeap A, HeapSize
For i = UBound(A) To 1 Step -1
Swap A(0), A(i)
HeapSize = HeapSize - 1
Heapify A, 0, HeapSize
Next
End Function ' Function HeapSort(ByRef A)
'*** v3.6 *** www.dieseyer.de *******************************
Sub BuildHeap(ByRef A, ByVal HeapSize)
'************************************************************
Dim i
For i = Int(HeapSize / 2) To 0 Step -1
Heapify A, i, HeapSize
Next
End Sub ' BuildHeap(ByRef A, ByVal HeapSize)
'*** v3.6 *** www.dieseyer.de *******************************
Sub Heapify(ByRef A, ByVal i, ByVal HeapSize)
'************************************************************
Dim l, r, Largest
l = 2 * i + 1
r = 2 * i + 2
Largest = i
If l < HeapSize Then
' If UCase( A(l) ) > UCase( A(i) ) Then Largest = l
If A(l) > A(i) Then Largest = l
End If
If r < HeapSize Then
If A(r) > A(Largest) Then Largest = r
' If UCase( A(r) ) > UCase( A(Largest) ) Then Largest = r
End If
If Largest <> i Then
Swap A(i), A(Largest)
Heapify A, Largest, HeapSize
End If
End Sub ' Heapify(ByRef A, ByVal i, ByVal HeapSize)
'*** v3.6 *** www.dieseyer.de *******************************
Sub Swap(ByRef L, ByRef R)
'************************************************************
Dim Temp
Temp = R
R = L
L = Temp
End Sub ' Swap(ByRef L, ByRef R)
#########################################################################
>>> sort-quicksort.vbs <<<
'*** v3.6 *** www.dieseyer.de *******************************
'
' Datei: sort-quicksort.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Sortiert die Zeilen einer Datei alphabetisch
'
' Das Sortieren auf einem Pentium 600MHz von
' 10.000 Zeilen VBScript-Code dauert ca. 2:30 min
' mit 100% CPU-Last
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim StartZeit : StartZeit = Timer()
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
' Fals ein Argument übergeben wurde, sollte es einen Dateinamen
' enthalten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then Datei = oArgs.item(i)
Next
' Gibt's keinen Dateinamen, werden halt die Zeilen des Skripts
' alphabetisch sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if Datei = "" then Datei = WScript.ScriptName
Text = Text & now() & vbCRLF
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
ReDim Preserve arrTest(i)
arrTest(i) = FileIn.Readline
i = i + 1
Loop
FileIn.Close
Set FileIn = nothing
Text = UBound(arrTest) & " Zeilen der Datei " & Datei & " werden jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert." & vbCRLF
QuickSort arrTest, LBound(arrTest), UBound(arrTest) ' Array "arrTest" wird sortiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = Text & UBound(arrTest) & " Zeilen der Datei " & Datei & " sind jetzt (" & now() & ") durch " & WScript.ScriptName & " sortiert."
' Zieldatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & ".txt"
' Datei mit sortierten Zeilen füllen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Lesen öffnen
' FileOut.WriteLine( Text & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound(arrTest)
FileOut.WriteLine( i+1 & vbTab & arrTest(i) )
next
' FileOut.WriteLine( vbCRLF & vbCRLF & now() ) ' nur Für Testzwecke
Text = Text & now()
FileOut.Close
Set FileOut = nothing
' Datei mit sortierten Zeilen anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.run Datei
MsgBox i & " Zeilen sind nach " & Timer() - StartZeit & "s sortiert.", 4096, WScript.ScriptName
WScript.Sleep 3000
' Datei mit sortierten Zeilen löschen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' fso.DeleteFile ( Datei )
WScript.Quit
'***************************************************************
'*** v8.3 *** www.dieseyer.de *******************************
Function QuickSort( vntArray, intVon, intBis )
'************************************************************
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' http://www.heise.de/ct/ftp/listings.shtml
' ftp://ftp.heise.de/pub/ct/listings/0205-207.zip
' 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 )
#########################################################################
>>> sound-text-ausgabe.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: sound-text-ausgabe.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Prozedur TextSprechenVbs( Txt )
' Sprechen eines Textes
'
' Prozedur PlayWaveVbs( WaveDatei )
' Wave-Datei ohne Player abspielen
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
PlayWaveVbs "C:\Windows\Media\ringin.wav"
WSCript.Sleep 3*1000
TextSprechenVbs( "Ish bin fettich." )
WScript.Quit
'*** v8.3 *** www.dieseyer.de *******************************
Sub PlayWaveVbs( WaveDatei )
'************************************************************
' Wave-Datei ohne Player abspielen
Dim objFile
Set objFile = CreateObject("SAPI.SpFileStream.1")
objFile.Open WaveDatei
CreateObject("SAPI.SpVoice").Speakstream objFile
Set objFile = nothing
End Sub ' PlayWaveVbs( WaveDatei )
'*** v8.3 *** www.dieseyer.de *******************************
Sub TextSprechenVbs( Txt )
'************************************************************
' Sprechen eines Textes
Createobject("sapi.spvoice").speak( Txt )
End Sub ' TextSprechenVbs( Txt )
#########################################################################
>>> specialfolders.vbs <<<
'*** v11.2 *** www.dieseyer.de *****************************
'
' Datei: specialfolders.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst, i
Tst = Tst & "-: " & CreateObject("WScript.Shell").ExpandEnvironmentStrings("%ProgramFiles%") & vbCRLF
For i = -110 to 115
On Error Resume Next
Tst = Tst & i & ": " & CreateObject("WScript.Shell").SpecialFolders( i ) & vbCRLF
On Error GoTo 0
' -: C:\Program Files
' 0: C:\Documents and Settings\All Users\Desktop
' 1: C:\Documents and Settings\All Users\Start Menu
' 2: C:\Documents and Settings\All Users\Start Menu\Programs
' 3: C:\Documents and Settings\All Users\Start Menu\Programs\Startup
' 4: C:\Documents and Settings\[%UserName%]\Desktop
' 5: C:\Documents and Settings\[%UserName%]\Application Data
' 6: C:\Documents and Settings\[%UserName%]\PrintHood
' 7: C:\Documents and Settings\[%UserName%]\Templates
' 8: C:\WINDOWS\Fonts
' 9: C:\Documents and Settings\[%UserName%]\NetHood
' 10: C:\Documents and Settings\[%UserName%]\Desktop
' 11: C:\Documents and Settings\[%UserName%]\Start Menu
' 12: C:\Documents and Settings\[%UserName%]\SendTo
' 13: C:\Documents and Settings\[%UserName%]\Recent
' 14: C:\Documents and Settings\[%UserName%]\Start Menu\Programs\Startup
' 15: H:\Favoriten
' 16: C:\Documents and Settings\[%UserName%]\My Documents
' 17: C:\Documents and Settings\[%UserName%]\Start Menu\Programs
' -: C:\Programme
' 0: C:\Dokumente und Einstellungen\All Users\Desktop
' 1: C:\Dokumente und Einstellungen\All Users\Startmenü
' 2: C:\Dokumente und Einstellungen\All Users\Startmenü\Programme
' 3: C:\Dokumente und Einstellungen\All Users\Startmenü\Programme\Autostart
' 4: C:\Dokumente und Einstellungen\[%UserName%]\Desktop
' 5: C:\Dokumente und Einstellungen\[%UserName%]\Anwendungsdaten
' 6: C:\Dokumente und Einstellungen\[%UserName%]\Druckumgebung
' 7: C:\Dokumente und Einstellungen\[%UserName%]\Vorlagen
' 8: C:\WINDOWS\Fonts
' 9: C:\Dokumente und Einstellungen\[%UserName%]\Netzwerkumgebung
' 10: C:\Dokumente und Einstellungen\[%UserName%]\Desktop
' 11: C:\Dokumente und Einstellungen\[%UserName%]\Startmenü
' 12: C:\Dokumente und Einstellungen\[%UserName%]\SendTo
' 13: C:\Dokumente und Einstellungen\[%UserName%]\Recent
' 14: C:\Dokumente und Einstellungen\[%UserName%]\Startmenü\Programme\Autostart
' 15: C:\Dokumente und Einstellungen\[%UserName%]\Favoriten
' 16: C:\Dokumente und Einstellungen\[%UserName%]\Eigene Dateien
' 17: C:\Dokumente und Einstellungen\[%UserName%]\Startmenü\Programme
Next
CreateObject("Scripting.FileSystemObject").OpenTextFile( WScript.ScriptFullName & ".txt", 2, true).WriteLine ( Tst )
Tst = Left( Tst, 1020 ) & "..."
MsgBox Tst, 4096, "64 :: Max. 1024 Zeichen!"
Tst = ""
For i = -10 to 15
On Error Resume Next
Tst = Tst & i & "| " & CreateObject("Scripting.FileSystemObject").GetSpecialFolder( i ) & vbCRLF
On Error GoTo 0
' 0| C:\Windows
' 1| C:\Windows\System32
' 2| C:\Users\[%UserName%]\AppData\Local\Temp
Next
MsgBox Tst, 4096, "76 :: Max. 1024 Zeichen!"
Wscript.Quit
#########################################################################
>>> spielchen.hta <<<
<!--
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: spielchen.hta
' Autor: mike-winxp@gmx.de
' Auf: www.dieseyer.de
'
'************************************************************
-->
<head>
<meta http-equiv="Content-Language" content="de">
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>Game without a name</title>
<HTA:APPLICATION ID="oHTA"
SCROLL="yes"
SHOWINTASKBAR="yes"
APPLICATIONNAME="Game without a name"
singleinstance="yes"
>
<style type="text/css">
<!--
body,td,th {
color: #CCCCCC;
font-family: Arial, Helvetica, sans-serif;
font-size: 10px;
}
body {
background-color: #4a4a4a;
}
a {
font-size: 10px;
color: #CCCCCC;
}
a:link {
text-decoration: none;
}
a:visited {
text-decoration: none;
color: #CCCCCC;
}
a:hover {
text-decoration: underline;
}
a:active {
text-decoration: none;
}
.Stil1 {font-size: 14px}
.Stil2 {font-size: 10px; }
-->
</style>
</head>
<script language="VBscript">
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim WSHnet : Set WSHnet = CreateObject("WScript.NetWork")
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
Dim Zahlen : Zahlen = "123456789111213141516171819"
Dim click : click = 0
Dim click2
Dim save
'****************************************
sub Beim_Laden()
'****************************************
' window.moveto Links, Oben
' window.moveto 0, 0
' window.resizeto Breite, Höhe
window.resizeto 750, screen.height-130
' window.resizeto 650, 550
call Install
iText = iText & "<center><input type='button' value='Infos ausblenden' name='information' onClick='ausblenden()' style='background-color: #54514D; background-repeat: repeat; background-attachment: scroll; color: #CCCCCC; position: relative; border-style: outset; border-width: 1; background-position: 0% 50%' ></center>"
iText = iText & "<br></br><br></br>"
iText = iText & "<center><u>Die Regeln:</u></font></center>"
iText = iText & "<p align='center'><font face='Lucida Calligraphy' size'1'>Du darfst gleiche Zahlen, die übereinander bzw. "
iText = iText & "nebeneinander liegen, wegstreichen.<br>"
iText = iText & "<br>"
iText = iText & "Auch wenn die Summe zweier (nebeneinander / übereinander liegender) Zahlen 10 ergibt, dürfen diese gestrichen werden. <br>"
iText = iText & "<br>"
iText = iText & "Dies gilt auch für die letzte Zahl in einer Reihe und die erste Zahl der darauf folgenden Reihe.<br>"
iText = iText & "<br>"
iText = iText & "Wenn sich keine Zahlen mehr wegstreichen lassen, werden die übriggebliebenen Zahlen abgeschrieben "
iText = iText & "und alles beginnt von Neuem.<br>"
iText = iText & "<br>"
iText = iText & "Wenn eine Zahl gestrichen wurde, dürfen auch die Zahlen daneben gestrichen werden, wenn einer der oben genannten Fälle eingetreten ist:<br>"
iText = iText & "<br>"
iText = iText & "Beispiel:<br>"
iText = iText & "Stehen 121 nebeneinander und über der 2 steht eine 8, ergibt das 10, dann dürfen auch die 1er gestrichen "
iText = iText & "werden (da gleiche Zahl). </font><font size='3' face='Lucida Calligraphy'><br>"
iText = iText & "<a href='http://www.picupload.net/uploads/c955b2368186d1c1beec9e08ca83edde.jpg' target='_blank'><font color='#FFFF00'>Weitere Infos</font></a></center>"
document.all.info.innerHTML = iText
iText = ""
save = Zahlen
end sub
'****************************************
sub Install()
'****************************************
TXT = TXT & "<table border='0' width='220' cellspacing='0' cellpadding='0'>"
TXT = TXT & "<tr>"
Do until a = Len(Zahlen)
a = a + 1
Zahl = Mid(Zahlen,a,1)
TXT = TXT & "<td width='100'><input type='button' id=" & a & " value='"&Zahl&"' onClick='Play(" & a & ")' name='" & a & "' style='width: 25; float: right; position: relative; border-width: 1; color: #CCCCCC; background-color: #54514D; height: 25' ></td>"
If a/9 = Fix(a/9)then TXT = TXT & "</tr><tr>"
Loop
TXT = TXT & "</tr></table>"
document.all.WeekEnd.innerHTML = TXT
TXT = ""
End Sub
'****************************************
Sub new_numbers()
'****************************************
if Len(Zahlen) >= 1000 Then overflow = WSHShell.popup("Overflow: Mehr als 1000 Zahlen werden nicht unterstützt",30,"Error",16) : exit Sub
a = 1
Do while a < Len(Zahlen)
If mid(Zahlen, a ,9 ) = " " Then Zahlen = left(Zahlen, a - 1) & Right(Zahlen,Len(Zahlen) - Len(left(Zahlen, a - 1)) - 9 ) : a = a - 9
a = a + 9
Loop
Zahlen = Zahlen & Replace(Zahlen," ", "")
call Install()
end Sub
'****************************************
Sub reset()
'****************************************
reset_nachfrage = WshShell.Popup("Möchten Sie dieses Spiel aufgeben?", 30,"Spiel ohne Name", 4 + 32 + 256)
if reset_nachfrage = 7 Then exit sub
Zahlen = "123456789111213141516171819"
call Install()
end sub
'**************************************** Button ueberpruefen
sub Play(button)
'****************************************
on error resume next
if button = click Then Exit sub
If Mid(Zahlen,button,1) = " " Then click = 0 : Exit sub
If click = 0 Then click = button : Exit Sub
If button = click - 1 or button = click + 1 or button = click - 9 or button = click + 9 Then
call click_erfolg(button)
Else
Set RegExp = new RegExp
With RegExp
.Pattern = "^ +$"
.IgnoreCase = True
.Global = True
End With
if button < click Then
if RegExp.Test(Mid(Zahlen,button + 1,click - button - 1)) = True Then call click_erfolg(button)
If (click - button)/9 = Fix((click - button)/9) then
i = 1
Do while i < (click - button)/9
if not Mid(Zahlen,i * 9 + button,1) = " " Then error = 1 : exit do
i = i + 1
loop
if error = 0 Then call click_erfolg(button)
End if
Else
if RegExp.Test(Mid(Zahlen,click + 1,button - click - 1)) = True Then call click_erfolg(button)
If (button - click)/9 = Fix((button - click)/9) then
i = 1
Do while i < (button - click)/9
if not Mid(Zahlen,i * 9 + click,1) = " " Then error = 1 : exit do
i = i + 1
loop
if error = 0 Then call click_erfolg(button)
End if
End if
Set RegExp = nothing
End if
error = 0
click = 0
end sub
'****************************************
Sub click_erfolg(click2)
'****************************************
on error resume next
var1 = Mid(Zahlen,click,1)/1
var2 = Mid(Zahlen,click2,1)/1
if var1 + var2 = 10 or var1 = var2 Then
save = Zahlen
Zahlen = Left(Zahlen ,click2 - 1 ) & " " & Right(Zahlen,Len(Zahlen)-click2 )
Zahlen = Left(Zahlen ,click - 1 ) & " " & Right(Zahlen,Len(Zahlen)-click )
Document.GetElementByID(click2).value=" "
Document.GetElementByID(click).value=" "
end if
end sub
'****************************************
Sub rueckgaengig()
'****************************************
Zahlen = save
call Install()
End Sub
'****************************************
Sub ausblenden()
'****************************************
document.all.info.innerHTML = ""
' window.moveto Links, Oben
' window.moveto 0, 0
' window.resizeto Breite, Höhe
window.resizeto 380, screen.height-130
' window.resizeto 320, 550
TXT = "<INPUT TYPE='button' value='Info einblenden' onClick='show_info' style='background-color: #54514D; background-repeat: repeat; background-attachment: scroll; color: #CCCCCC; position: relative; width: 150; border-style: outset; border-width: 1; background-position: 0% 50%' >"
document.all.einblenden.innerHTML = TXT
TXT = ""
call Install
End sub
'****************************************
Sub show_info
'****************************************
call Beim_Laden()
document.all.einblenden.innerHTML = ""
End sub
'****************************************
Sub test()
'****************************************
geht = False
a = 1
Do While a < Len(Zahlen)
If Mid(Zahlen,a,1) <> " " Then
number = Mid(Zahlen,a,1)/1
var1 = 0
var2 = 0
If Mid(Zahlen,a + 1,1) <> " " Then var1 = Mid(Zahlen,a + 1,1)/1
If Mid(Zahlen,a + 9,1) <> " " And a + 9 <= Len(Zahlen) Then var2 = Mid(Zahlen,a + 9,1)/1
If number = var1 Or number = var2 Or (number + var1) = 10 Or (number + var2) = 10 Then
geht = True
Else
b = 1
Do while Mid(zahlen,a + b,1) = " "
b = b + 1
Loop
If a + b <= Len(Zahlen) Then
If number = Mid(zahlen,a + b,1)/1 Or (number + Mid(zahlen,a + b,1)/1) = 10 Then geht = True
End If
b = 9
Do While Mid(zahlen,a + b,1) = " "
b = b + 9
Loop
If a + b <= Len(Zahlen) Then
If number = Mid(zahlen,a + b,1)/1 Or (number + Mid(zahlen,a + b,1)/1) = 10 Then geht = True
End If
End If
End If
a = a + 1
If geht = True Then messenge = msgbox("Test positiv. Es können noch weitere Zahlen weggestrichen werden.",64,"Test") : Exit Sub
Loop
messenge = msgbox("Test negativ. Es können keine weiteren Zahlen weggestrichen werden.",64,"Test")
End Sub
</script>
<body onLoad="ausblenden()">
<p>
<marquee style="font-size: 12pt" width="747" height="18">Bitte beachten Sie, dass sich dieses Programm
in der Betaphase befindet. Programmfehler sind nicht ausgeschlossen. Nutzung auf
eigene Gefahr</marquee>
</p>
<table border="0" width="103%" height="8" cellpadding="2">
<tr>
<td width="14%" height="8">
<center>
<div id=einblenden </div style="width: 157; height: 17">
</center>
</div>
</td>
<td width="13%" height="8">
<center><INPUT TYPE="button" value="Reset" onClick="reset()" style="background-color: #54514D; background-repeat: repeat; background-attachment: scroll; color: #CCCCCC; position: relative; width: 150; border-style: outset; border-width: 1; background-position: 0% 50%" >
</center>
</td>
<td width="33%" height="8" rowspan="2"></td>
<td width="44%" height="4" rowspan="4"></td>
</tr>
<tr>
<td width="14%" height="1">
<center><INPUT TYPE="button" value="Rückgängig" onClick="rueckgaengig()" style="background-color: #54514D; background-repeat: repeat; background-attachment: scroll; color: #CCCCCC; position: relative; width: 150; border-style: outset; border-width: 1; background-position: 0% 50%" ></center>
</td>
<td width="13%" height="1">
<center><INPUT TYPE="button" value="Zahlen geben" onClick="new_numbers()" style="background-color: #54514D; background-repeat: repeat; background-attachment: scroll; color: #CCCCCC; position: relative; width: 150; border-style: outset; border-width: 1; background-position: 0% 50%" >
</center>
</td>
</tr>
<tr>
<td width="27%" height="29" colspan="2">
<center> <INPUT TYPE="button" value="Können noch weitere Zahlen gestrichen werden?" onClick="test()" style="background-color: #54514D; background-repeat: repeat; background-attachment: scroll; color: #CCCCCC; position: relative; width: 312; border-style: outset; border-width: 1; background-position: 0% 50%" >
</center>
</td>
<td width="33%" height="2" rowspan="2">
<font face="Lucida Calligraphy" size="1">
<div id=info style="width: 346; height: 32"> </div>
</font></td>
</tr>
<tr>
<td width="27%" height="29" colspan="2">
<center><div id=WeekEnd style="width: 315; height: 25"></div></center>
</td>
</tr>
</table>
<p><center></center></p>
<p>
</p>
</body>
#########################################################################
>>> split-test.vbs <<<
'v6.2*****************************************************
' File: split-test.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Wenn das Trennzeichen für die Split-Funktion das Komma
' ist, in der zu zerlegenden Zeichenkette aber Dezimal-
' zahlen (also auch mit Komma, aber mit Anführungszeichen
' eingegrenzt) enthalten sind, kann man es so machen:
'
'***************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, Tst, i
Txt = "01.12.05,Türkei_Ziel_Winter_05,Side_Winter,Colakli,Weitgehend,Aktiv,""0,17"",""0,60"",Standard-URL,16,0,""0,0%"",""0,00"",""0,00"",""2,0"""
MsgBox Txt , , "17:: " & WScript.ScriptName
Tst = Split( Txt, "," )
For i = LBound( Tst ) to UBound( Tst )
If InStr( Tst(i), """" ) > 0 AND i < UBound( Tst ) Then
Tst(i) = Tst(i) & "," & Tst(i+1) : Tst(i+1) = ""
Tst(i) = Replace( Tst(i), """", "" )
End If
Next
' For i = LBound( Tst ) to UBound( Tst )
' Txt = Txt & vbCRLF & i & vbTab & Tst(i)
' Next
' MsgBox Txt , , "35:: " & WScript.ScriptName
For i = LBound( Tst ) to UBound( Tst )
If Len( Tst(i) ) > 0 Then Txt = Txt & vbCRLF & i & vbTab & Tst(i)
Next
MsgBox Txt , , "38:: " & WScript.ScriptName
#########################################################################
>>> standarddrucker.hta <<<
<script language="VBScript" type="text/vbscript">
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: standarddrucker.hta
' Autor: CMDR 20080423
' Auf: www.dieseyer.de
'
'*********************************************************
Dim zzz
zzz=0
'**** Aufblitzen des Fensters wird verhindert ! *****
'**** Unkonventioneller Ort, aber wirksam. *****
Do while zzz<100
on error resume next
window.resizeTo 0,0
window.moveTo -2000,-2000
zzz=zzz+1
Loop
on error goto 0
</script>
<HTML>
<HEAD>
<HTA:APPLICATION ID="STDPRT"
APPLICATIONNAME="STDPRT"
BORDER="thick"
BORDERSTYLE="normal"
CAPTION="yes"
MAXIMIZEBUTTON="no"
MINIMIZEBUTTON="yes"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
SELECTION="no"
SCROLL="no"
SYSMENU="yes"
VERSION="1.8 CMDR 20080329/Dieseyer"
WINDOWSTATE="normal"
ICON="stdprt_i.ico"
>
<style type="text/css">
body {font-family:Arial,sans-serif,Helvetica,Verdana;font-size:16px;
background-color:#000080;color:#E0E0E0;
filter:progid:DXImageTransform.Microsoft.Gradient(GradientType=1,
StartColorStr='#000010',EndColorStr='#0000FF')}
</style>
<script language="VBScript" type="text/vbscript">
Dim endflag,hlpflag,phflag,deinstflag,kflag,standardW98,WshShell
Dim WshNetwork,fs,ToolName,strDesktop,LinkName,LinkIcon,a,ug,og,htaID,CLine
Dim EigenerVollName,EigenerPfad,EigenerName,param,eh,Drucker(),StdDr
endflag=1:hlpflag=0:phflag=0:deinstflag=0:kflag=0
standardW98="" 'als Flag f. W98
Set WshShell = CreateObject("WScript.Shell")
Set WshNetwork = CreateObject("WScript.Network")
Set fs = CreateObject("Scripting.FileSystemObject")
ToolName = "Standarddrucker wählen"
document.title=" "&ToolName&" (Hilfe mit F1)"
strDesktop = WshShell.SpecialFolders("Desktop")
LinkName = strDesktop&"\"&ToolName&".lnk"
'HTA-Tag ID auslesen(interessant,dass dies geht!)
a=document.getElementsByTagName("head")(0).innerHtml
'Es lohnt sich auch ein Blick auf den vom IE veränderten Quellcode (MsgBox a)!
ug=inStr(Lcase(a),"id=")+3
og=inStr(ug,a," ")
htaID=mid(a,ug,og-ug)
CLine=document.getElementById(htaID).commandLine
If(left(CLine,1)="""") then CLine=mid(CLine,2) 'ggf. Anführungszeichen entfernen
EigenerVollName=left(CLine,inStrRev(LCase(CLine),".hta")+3)
Pfad=mid(EigenerVollName,1,inStrRev(CLine,"\"))'Backslash am Schluss
EigenerPfad=left(Pfad,len(pfad)-1)
LinkIcon = "stdprt.ico"
EigenerName=mid(EigenerVollName,inStrRev(EigenerVollName,"\")+1)
param=LCase(CLine)
param=mid(param,inStr(param,".hta")+5)
param = Trim(param)
'******* Unterprogramme ********
Sub eventHandler
if(window.event.type="keydown") then
if(hlpflag=0) then Auswahl.focus 'Tastaturbedienung sofort möglich
if(window.event.keyCode=112 And hlpflag=0) then hilfe
if(window.event.keyCode=13 And hlpflag=0) then SetPrinter
if(window.event.keyCode=27) then Window.close
end if
End Sub
Sub startScript
if(Not fs.FileExists(document.getElementById(htaID).icon)) then
InstallScript
elseIf(Not fs.FileExists(Pfad & LinkIcon)) then
CreateImage "icolink", Pfad & LinkIcon
location.reload
else
endflag=0
end if
if (endflag=1) then WinClose:exit sub
Dim oPrinters,anzahl,h,m,altlen,anzeige,format,SDrucker,br,ho
'wegen W98 ohne WMI
Set oPrinters = WshNetwork.EnumPrinterConnections
anzahl = (oPrinters.Count)/2
Redim Drucker(anzahl)
StdDr=StandardDrucker
h=0
m=""
altlen=0
anzeige=""
if(anzahl>0) then
For i = 0 to 2*anzahl - 1 Step 2
h=h+1
if h<10 Then
m=chr(160)&chr(160) & CStr(h)
else
m=CStr(h)
end if
format=m & ". " & oPrinters.Item(i+1)
if (len(format)>altlen) then altlen=len(format)
Drucker(h-1)=oPrinters.Item(i+1)
if Drucker(h-1)=StdDr then
SDrucker=" selected='selected' style='color:#00FFFF;background-color:#3030A0'"
else
SDrucker="style='color:#FF9090;background-color:#3030A0'"
end if
anzeige = anzeige & "<option value='" & CStr(h) & "'" & SDrucker & ">" & format & "</option>"
Next
end if
if (anzahl=1) then
PrtBox.innerHtml="<select size='2' name='Auswahl' onDblClick='window.close()'>" _
& anzeige& "<option style='background-color:#9090D0'/></select>"
Strd.innerHtml="<font style='color:#FFFF00'>Es gibt nur einen Drucker. <br/>" _
& "Sie haben keine Auswahl.</font>"
window.setTimeout "window.close()",5000
exit sub
end if
anzeige = "<select size='" & CStr(anzahl) & "' name='Auswahl' onChange='chgPrt' " _
& "onDblClick='setPrinter' style='font-size:16px;font-weight:bolder'>" & anzeige
anzeige = anzeige & "</select>"
PrtBox.innerHtml=anzeige
Strd.innerHtml ="Ihre Wahl :<br/><br/><b>Alter Standard-Drucker :<br/>" & StdDr & "</b>"
' Fenstergestaltung /-positionierung
if(altlen>38) then
br=370+(altlen-38)*30
else
br=370
end if
ho=320+anzahl*20
zzz=0
'**** Fenster positionieren *****
Do while zzz<100
on error resume next
Window.resizeTo br,ho
Window.moveTo (Screen.Width-br)/2,(Screen.Height-ho)/2
zzz=zzz+1
Loop
on error goto 0
End Sub
function StandardDrucker
StandardDrucker=""
'Win Vista/XP
on error resume next
Set objPrt = GetObject("winmgmts://./root/cimv2").InstancesOf("Win32_Printer")
if(Err<>0) then
Err.Clear
'Win 98 (Der Schlüssel existiert auch in Win 2K/Win XP, wird aber nicht genutzt/aktualisiert.)
'oder WMI nicht installiert
standardW98 = WshShell.RegRead ("HKEY_CURRENT_CONFIG\System\CurrentControlSet\Control\Print\Printers\Default")
if (Err=0) Then StandardDrucker=standardW98:on error goto 0:Exit Function
Err.Clear
end if
For Each result in objPrt
If (result.default) then StandardDrucker=result.name
If(Err<>0) then Err.Clear:StandardDrucker="":Exit For 'W2k-Fehler
Next
set objPrt=nothing
if(StandardDrucker<>"") then on error goto 0:Exit Function
'Win 2K/XP(Version 5.x)
Dim standardV5,ende
standardV5 = WshShell.RegRead ("HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows\Device")
if (Err=0) Then ende = inStr(standardV5,","):StandardDrucker=Left(standardV5,ende-1)
On Error Goto 0
if(StandardDrucker<>"") then Exit Function
MsgBox "Es gibt keinen Drucker oder"&vbLf&"der Standard-Drucker ist nicht ermittelbar.",48," F E H L E R"
WinClose
End function
Sub chgPrt
'"Statuszeile"
if (Drucker(CInt(Auswahl.value)-1)<>StdDr) then
Strd.innerHtml ="Ihre Wahl :<br/>( bitte Doppelklick oder [ <b><</b><sup>_<small>|</small></sup> ] )" _
& "<br/><br/><b>Neuer Standard-Drucker :<br/>" & Drucker(CInt(Auswahl.value)-1) & "</b>"
else
Strd.innerHtml ="Ihre Wahl :<br/><br/><b>Alter Standard-Drucker :<br/>" & Drucker(CInt(Auswahl.value)-1) & "</b>"
end if
End Sub
Sub setPrinter
if (Drucker(CInt(Auswahl.value)-1)<>StdDr) then WshNetwork.SetDefaultPrinter Drucker(CInt(Auswahl.value)-1)
if(kflag=0) then
WinClose
else
location.reload
end if
End Sub
Sub DtopLink (tget,b)
Dim NewLink,PrgPath
PrgPath=left(tget,inStrRev(tget,"\"))
' ******** Desktop-Link wird erstellt ******
if (fs.FileExists(LinkName)) then fs.DeleteFile LinkName,true
set NewLink = WshShell.CreateShortcut(LinkName)
NewLink.TargetPath = tget
NewLink.WindowStyle = 1
NewLink.IconLocation = PrgPath & LinkIcon
NewLink.HotKey = "CTRL+ALT+D"
NewLink.Description = "Wählen Sie den"&vbLf&"Standarddrucker"&vbLf&"mit 2 Mausklicks !"
NewLink.WorkingDirectory = left(PrgPath,len(PrgPath)-1)
on error resume next
NewLink.Save
if Err<>0 then
MsgBox "Desktop-Link konnte nicht erstellt werden !",48,"F E H L E R"
exit sub
end if
on error goto 0
MsgBox "Desktop-Link erstellt!",0,"Hinweis"
if(b=1) then WinClose
End Sub
Sub InstallScript
Dim strInst
if (MsgBox("Möchten Sie """ & ToolName & """ installieren ?",vbQuestion+vbYesNo,"Installation """ & ToolName &"""")<>6) then endflag=1:exit sub
strInst=BrowseFolder
if(inStr(strInst,"!")) then
MsgBox strInst,48,"Fehler"
window.close
end if
fs.CopyFile EigenerVollName,strInst & "\"
CreateImage "ico", strInst & "\" & document.getElementById(htaID).icon
CreateImage "icolink", strInst & "\" & LinkIcon
DtopLink strInst & "\" & EigenerName,0
MsgBox "Installation beendet !",0,ToolName
End Sub
Sub DeInst
Dim tmp,PrgName,f
deinstflag=1
'**** Erstellen einer zusätzlichen VBScript-Datei im %TEMP%-Ordner
'**** zum Löschen, damit auch der (leere!) Installationsordner
'**** gelöscht werden kann.
'**** Das Löschen des leeren Ordners funktioniert nur, wenn das HTA-
'**** Fenster zu diesem Zeitpunkt bereits geschlossen ist. Eventuell
'**** muß man in die VBScript-Datei ein "WScript.Sleep ..." einfügen.
tmp=WshShell.ExpandEnvironmentStrings("%temp%")
PrgName = tmp&"\"&"del.vbs"
set f=fs.OpentextFile(PrgName,2,true)
'f.WriteLine "WScript.Sleep 1000"
f.WriteLine "Set fs = CreateObject(""Scripting.FileSystemObject"")"
f.WriteLine "Set Ws = CreateObject(""WScript.Shell"")"
f.WriteLine "fs.DeleteFile """ & EigenerVollName & """"
f.WriteLine "pf=""" & EigenerPfad & """"
f.WriteLine "set ff = fs.GetFolder(pf)"
f.WriteLine "if (ff.Files.count=0 And ff.SubFolders.count=0) then"
f.WriteLine "Ws.CurrentDirectory=pf " & chr(38) & " ""\.."""
f.WriteLine "fs.DeleteFolder pf"
f.WriteLine "end if"
f.WriteLine "MsgBox ""Programm vollständig entfernt !"",vbInformation ,""Ende"""
f.WriteLine "fs.DeleteFile """ & PrgName &""""
f.close
set f= nothing
'**** Die Abfrage läßt genügend Zeit für die Fertigstellung der VBScript-Datei,das erspart eine programmierte Zeitverzögerung.
if((MsgBox ("Wollen Sie wirklich "&chr(34)&ToolName&chr(34)&" löschen ?",vbQuestion+vbYesNo+vbDefaultButton2,"Deinstallation"))<>6) then
'**** Keine Deinstallation : die VBScript-Datei wird gelöscht.
fs.DeleteFile PrgName
exit sub
end if
'**** Deinstallation : Desktop-Link wird gelöscht, wenn noch vorhanden und nicht umbenannt, sonst Meldung
if (fs.FileExists(LinkName)) then
fs.DeleteFile LinkName
else
MsgBox "Der Desktop-Link konnte nicht gelöscht werden." _
& vbLf & "Möglicherweise wurde er umbenannt,"&vbLf&"bereits gelöscht oder verschoben.",48,"Hinweis"
end if
'**** Icon löschen
if (fs.FileExists(EigenerPfad & "\" & LinkIcon)) then
fs.DeleteFile EigenerPfad & "\" & LinkIcon
end if
'**** document.getElementById(htaID).icon liefert den kompletten Pfad !
if (fs.FileExists(document.getElementById(htaID).icon)) then
fs.DeleteFile document.getElementById(htaID).icon
end if
'**** Lösch-Script starten
WshShell.Run PrgName,0,false
WinClose
End Sub
Function BrowseFolder()
dim shll,pfd,ordner(),wahl,x,z,strQ
set shll = CreateObject("Shell.Application")
x="":pfd=""
strQ="Wählen Sie einen Ordner aus" & vbLf & "oder erstellen einen neuen :"
on error resume next
set wahl = shll.BrowseForFolder(0,strQ,64,17)
x=wahl.Title
if x<>"" then
ReDim ordner(2)
set ordner(1)=wahl
z=1
while instr(ordner(z),":")=0
set ordner(z+1)=ordner(z).ParentFolder
if instr(ordner(z+1),":")>0 then
wahl=mid(ordner(z+1),instr(ordner(z+1),":")-1,2)
end if
pfd=ordner(z)&"\"&pfd
z=z+1
ReDim Preserve ordner(z+1)
wend
pfd=wahl&"\"&pfd:pfd=mid(pfd,1,len(pfd)-1)
end if
if(inStr(pfd,":)")>0) then pfd = "Die Auswahl eines Stammordners auf " & pfd & " wird nicht unterstützt !"
BrowseFolder=pfd
'**** ... oder eben doch : if (inStr(pfd,":)")<>0) then pfd=mid(pfd,inStr(pfd,":")-1,2)&"\"
'**** Der Root-Folder von Laufwerken wird in der Form "Name/Typ (LW:)" ausgegeben (XP/Vista)
set shll=nothing
End Function
Sub hilfe()
br=370:h=510
Window.resizeTo br,h
on error resume next
'**** manchmal wird die Erlaubnis verweigert !
Window.moveTo (Screen.Width-br)/2,(Screen.Height-h)/2
on error goto 0
PrtBox.innerhtml="":Strd.innerhtml=""
a="<h2>H I L F E</h2><div style='text-align:justify;width:300px'>"
a=a&"Wählen Sie den Standard-Drucker mit zwei Mausklicks oder prüfen Sie, ob Netzwerkdrucker verfügbar sind. "
a=a&"Starten Sie das Programm bequem mit einem Desktop-Link. Das Programm installiert sich beim ersten Aufruf.</div><div style='text-align:left;width:300px'>"
a=a&"<br/><br/>Folgende Parameter sind möglich:<br/><table>"
a=a&"<tr><td style='padding-right:30px'>(-)H|?</td><td> dieser Hilfetext (auch mit F1)</td></tr>"
a=a&"<tr><td>(-)K </td><td> Fenster bleibt offen</td></tr>"
a=a&"<tr><td> </td></tr>" ' "Fester LeerSchritt" = , sonst keine Leerzeile
a=a&"<tr><td><input type=""Button"" name""ReLink"" value="" Link "" onClick=""DtopLink '" & EigenerVollName & "',0""> </td><td> Desktop-Link neu erstellen</td></tr>"
a=a&"<tr><td><input type=""Button"" name""DeInst"" value=""DeInst"" onClick=""DeInst"" accesskey=""d""> </td><td> Deinstallation - auch [Alt-d]</td></tr></table><br/>"
a=a&"Refresh erfolgt automatisch. Ende mit ESC</div>"
if(phflag=0) then a=a&"<div align='right'><sub>Weiter mit F5</sub> __<sub><b>></b></sub></span>"
a=a&""
vsp.innerHtml=a
hlpflag=1
End Sub
Sub CreateImage(id,icn)
'***** Bilddatei aus Hexadezimalwerten in SPAN-Tags erstellen und aktivieren.
'***** id= id des <span>-Tags; icn=Name der neuen Bilddatei; wenn icn="" Name aus "icon"-Attribut des HTA-Tag;
'***** Einstellige Hexadezimalzahlen sind möglich : anstatt 00 09 02 geht auch 0 9 2
'***** Zur Umwandlung eines Bildes in hexadezimale Ziffernfelder eignet sich hervorragend "HxD",
'***** kostenlos unter http://download.chip.eu/de/HxD-1.7.1.0b_554715.html
Dim c,ImgName
'Icon-Attribut aus HTA-Tag auslesen oder Bildnamen aus Parameter übernehmen
ImgName=""
c=icn
if(c="") then
on error resume next
c=document.getElementById(htaID).icon
on error goto 0
else
if(inStr(c,":")=0) then c=Pfad&c
end if
ImgName=c
If(ImgName="") then Exit Sub 'dann eben keines!
if(Not fs.FileExists(ImgName)) then
Dim ImgData,pointer,Daten
'Hexadezimal- in Binärwerte umwandeln, wenn Icon-Datei noch nicht existiert
ImgData=document.getElementById(id).innerHtml
Daten=""
'Leerzeichen am Anfang beseitigen
if(left(ImgData,1)=" ") then ImgData=mid(ImgData,2)
Do while Len(ImgData)>0
pointer=inStr(ImgData," ")
'es gibt keine Leerräume mehr,aber noch eine (ein-oder zweistellige) Hex-Zahl am Ende
if(pointer=0 And Len(ImgData)<3) then
Daten=Daten&chr(CInt("&H"&ImgData))
Exit Do
end if
if(pointer<2) then Exit Do
Daten=Daten&chr(CInt("&H"&left(ImgData,pointer-1)))
If(Len(ImgData)>=pointer+1) then
ImgData=mid(ImgData,pointer+1)
else
Exit Do
end if
Loop
'Icon-Datei speichern
on error resume next
Set f=fs.OpenTextFile(ImgName,2,true)
if(Err<>0) then on error goto 0:Exit Sub 'Datei konnte nicht angelegt werden
f.Write Daten
f.close
end if
End Sub
Sub PrtFldr
WshShell.Run "control.exe printers",3,false
WinClose
End Sub
Sub fertig
location.reload
End Sub
Sub WinClose
Dim zzz
zzz=0
Do while zzz<10
window.close
zzz=zzz+1
Loop
End Sub
</script>
</HEAD>
<BODY>
<p><div align=center>
<span id=vsp><br/>(Bitte wählen Sie mit Maus oder Tasten.)<br/><br/><b><span onClick="PrtFldr" title="Klicken Sie hier, um den Druckerordner zu öffnen." style="cursor:hand"><u>Verfü</u>g<u>bare Drucker :</u></span>
</b><br/>(Standarddrucker bleibt <span style='color:#00FFFF;font-weight:bold'>markiert</span>.)<br/><br/></span><span id=PrtBox></span></p><p><span id=Strd>
</span></p></div>
<span id='ico' style='display:none'>0 0 1 0 1 0 10 10 0 0 1 0 18 0 68 3 0 0 16 0 0 0 28 0 0 0 10 0 0 0 20 0 0 0 1 0 18 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 12 12 12 44 44 44 30 30 30 17 17 17 38 30 30 78 71 71 24 24 24 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 36 36 36 A4 A4 A4 F1 F1 F1 B2 B2 B2 9E 8B 8B A6 86 86 B6 B3 B3 E5 E5 E5 B6 B6 B6 3C 3C 3C 0 0 0 0 0 0 0 0 0 0 0 0 41 41 41 96 96 96 EE EE EE F1 F1 F1 E8 E8 E8 AC AC AC 93 93 93 5F 5F 5F 6D 6D 6D 8C 8C 8C BC BC BC E9 E9 E9 B2 B2 B2 0 0 0 0 0 0 0 0 0 C1 C1 C1 FA FA FA F2 F2 F2 D8 D8 D8 95 95 95 7E 7E 7E 97 97 97 B2 B2 B2 A6 A6 A6 94 94 94 8E 8E 8E 89 89 89 5F 5F 5F 0 0 0 0 0 0 0 0 0 AE AE AE D8 D8 D8 A0 A0 A0 9B 9B 9B C9 C9 C9 AB AB AB 8D 8D 8D 80 80 80 83 83 83 9F 9F 9F BF BF BF 7A AA 8A 4E 4E 4E 0 0 0 0 0 0 0 0 0 76 76 76 A6 A6 A6 D9 D9 D9 D8 D8 D8 D8 D8 D8 D8 D8 D8 E0 E0 E0 CF CF CF BE BE BE 9D 9D 9D 89 89 89 67 84 71 4D 4D 4D 0 0 0 0 0 0 0 0 0 9E 9E 9E E1 E1 E1 D8 D8 D8 D2 D2 D2 C9 C9 C9 D5 D5 D5 CE CE CE C2 C2 C2 C0 C0 C0 CC CC CC D4 D4 D4 CC CC CC 67 67 67 0 0 0 0 0 0 0 0 0 93 93 93 D5 D5 D5 C2 C2 C2 AA AA AA A5 A5 A5 CF CF CF F0 F0 F0 ED ED ED EA EA EA D9 D9 D9 BF BF BF BE BE BE 5C 5C 5C 0 0 0 0 0 0 0 0 0 61 61 61 6B 6B 6B C9 C9 C9 EC EC EC B2 B2 B2 BA BA BA AE AE AE B6 B6 B6 BD BD BD BD BD BD 5C 5C 5C 8C 8C 8C 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 BD B3 B3 FF D4 C5 FF D2 C7 FB D7 CE EF DC D5 E5 E1 DF E7 E7 E7 68 68 68 75 75 75 9D 9D 9D 0 0 0 0 0 0 9D 9D 9D 0 0 0 0 0 0 0 0 0 BF 93 86 FF DC B8 FF DC B8 FF DC B8 FF D6 B3 FF D4 AF 68 4C 4A 75 75 75 9D 9D 9D 0 0 0 FF FF FF 0 0 0 0 0 0 9D 9D 9D 0 0 0 0 0 0 C6 A0 94 FF E5 CB FF E5 CB FF E5 CB FF E5 CB F9 DD C4 75 75 75 0 0 0 0 0 0 FF FF FF C0 C0 C0 FF FF FF 0 0 0 0 0 0 0 0 0 99 66 66 DF C3 B7 FF ED DC FF ED DC FF ED DC FF ED DC DB C1 B5 0 0 0 0 0 0 0 0 0 C0 C0 C0 0 0 0 C0 C0 C0 FF FF FF 0 0 0 0 0 0 AC 86 84 FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE 9F 8D 88 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 C0 C0 C0 0 0 0 99 66 66 C7 AB AA F7 F2 F1 E6 D8 D7 E6 D8 D7 E6 D8 D7 EB E0 DF 99 66 66 0 0 0 0 0 0 0 0 0 9D 9D 9D 0 0 0 0 0 0 0 0 0 0 0 0 FF FF 0 0 E0 3F 0 0 C0 F 0 0 0 7 0 0 0 7 0 0 0 7 0 0 0 7 0 0 0 7 0 0 0 7 0 0 0 F 0 0 C0 1 0 0 C0 0 0 0 C0 40 0 0 80 C0 0 0 80 C0 0 0 0 E1 0 0 </span>
<span id='icolink' style='display:none'>0 00 1 0 1 0 30 30 0 0 1 0 18 0 A8 1C 0 0 16 0 0 0 28 0 0 0 30 0 0 0 60 0 0 0 1 0 18 0 0 0 0 0 0 0 0 0 60 0 0 0 60 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 51 51 51 34 34 34 3B 3B 3B 75 75 75 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 69 69 69 37 37 37 37 37 37 69 69 69 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6A 6A 6A 37 37 37 41 41 41 75 75 75 3D 3D 3D 37 37 37 37 37 37 4E 4E 4E 0 0 0 0 0 0 0 0 0 3B 3B 3B 6C 59 59 B9 8C 8C ED ED ED 99 99 99 4E 4E 4E 57 57 57 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 80 80 80 3E 3E 3E 43 43 43 94 94 94 E7 E7 E7 D1 D1 D1 AB AB AB 85 85 85 57 57 57 37 37 37 37 37 37 34 34 34 66 56 56 B9 8C 8C CC 99 99 C3 96 96 FF FF FF FF FF FF FF FF FF B4 B4 B4 66 66 66 4E 4E 4E 9C 9C 9C 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4C 4C 4C 39 39 39 80 80 80 DD DD DD F2 F2 F2 EF EF EF CF CF CF B0 B0 B0 B2 B2 B2 B4 B4 B4 A5 A5 A5 77 77 77 A6 80 80 CC 99 99 BF 92 92 92 7F 7F 7A 7A 7A 8A 8A 8A C0 C0 C0 F1 F1 F1 FF FF FF FF FF FF D9 D9 D9 80 80 80 4E 4E 4E 80 80 80 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5C 5C 5C 3B 3B 3B 6A 6A 6A C9 C9 C9 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED CC CC CC AE AE AE B0 B0 B0 B2 B2 B2 B4 B4 B4 B4 B4 B4 B1 88 88 7F 6C 6C 5B 5B 5B 64 64 64 70 70 70 7A 7A 7A 83 83 83 8F 8F 8F AB AB AB DA DA DA FA FA FA FF FF FF F2 F2 F2 A7 A7 A7 54 54 54 69 69 69 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 79 79 79 41 41 41 54 54 54 B4 B4 B4 F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA C9 C9 C9 AC AC AC AE AE AE B0 B0 B0 B2 B2 B2 B4 B4 B4 5C 5C 5C 45 45 45 51 51 51 5B 5B 5B 64 64 64 70 70 70 7A 7A 7A 83 83 83 8F 8F 8F 99 99 99 AB AB AB CC CC CC F1 F1 F1 FF FF FF FF FF FF CC CC CC 75 75 75 61 61 61 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 48 48 48 4A 4A 4A 9E 9E 9E FA FA FA F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA E7 E7 E7 C6 C6 C6 A9 A9 A9 AC AC AC AE AE AE B0 B0 B0 B2 B2 B2 63 63 63 3D 3D 3D 45 45 45 51 51 51 5B 5B 5B 64 64 64 70 70 70 7A 7A 7A 83 83 83 8F 8F 8F 99 99 99 A5 A5 A5 B0 B0 B0 C2 C2 C2 E3 E3 E3 FD FD FD FF FF FF E7 E7 E7 99 99 99 85 85 85 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 59 59 59 41 41 41 89 89 89 F1 F1 F1 FA FA FA F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA E7 E7 E7 E5 E5 E5 C5 C5 C5 A7 A7 A7 A9 A9 A9 AC AC AC AE AE AE B0 B0 B0 B2 B2 B2 A5 A5 A5 83 83 83 5B 5B 5B 51 51 51 5B 5B 5B 64 64 64 70 70 70 7A 7A 7A 83 83 83 8F 8F 8F 99 99 99 A5 A5 A5 B0 B0 B0 BB BB BB C5 C5 C5 E0 E0 E0 F5 F5 F5 FF FF FF 6C 6C 6C 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 43 43 43 70 70 70 DD DD DD FD FD FD FA FA FA F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA E7 E7 E7 E5 E5 E5 E3 E3 E3 C2 C2 C2 A5 A5 A5 A7 A7 A7 A9 A9 A9 AC AC AC AE AE AE B0 B0 B0 B2 B2 B2 B4 B4 B4 B4 B4 B4 AB AB AB 8D 8D 8D 6F 6F 6F 64 64 64 70 70 70 7A 7A 7A 83 83 83 8F 8F 8F 99 99 99 A5 A5 A5 B0 B0 B0 BB BB BB B4 B4 B4 94 94 94 6C 6C 6C 6F 6F 6F 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 45 45 45 FF FF FF FD FD FD FA FA FA F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA E7 E7 E7 E5 E5 E5 E3 E3 E3 D1 D1 D1 93 93 93 99 99 99 A5 A5 A5 A7 A7 A7 A9 A9 A9 AC AC AC AE AE AE B0 B0 B0 B2 B2 B2 B4 B4 B4 B4 B4 B4 B7 B7 B7 B9 B9 B9 B0 B0 B0 99 99 99 0 0 0 7A 7A 7A 83 83 83 8F 8F 8F 80 80 80 66 66 66 66 66 66 4A 4A 4A 3E 3E 3E 43 43 43 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 46 46 46 FD FD FD FA FA FA F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA E7 E7 E7 E5 E5 E5 CC CC CC 94 94 94 66 66 66 66 66 66 66 66 66 6F 6F 6F 83 83 83 93 93 93 A9 A9 A9 AC AC AC AE AE AE B0 B0 B0 B2 B2 B2 B4 B4 B4 B4 B4 B4 B7 B7 B7 B9 B9 B9 BB BB BB BD BD BD B7 B7 B7 A0 A0 A0 66 66 66 33 33 33 33 33 33 A5 A5 A5 CC CC CC 80 80 80 46 46 46 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 48 48 48 FA FA FA F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA E7 E7 E7 C5 C5 C5 86 86 86 66 66 66 85 85 85 B4 B4 B4 BB BB BB 99 99 99 89 89 89 70 70 70 66 66 66 6A 6A 6A 80 80 80 97 97 97 AE AE AE B0 B0 B0 B2 B2 B2 B4 B4 B4 B4 B4 B4 B7 B7 B7 B9 B9 B9 BB BB BB BD BD BD C0 C0 C0 C2 C2 C2 BB BB BB 8F 8F 8F B4 B4 B4 C9 C9 C9 89 89 89 48 48 48 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 4A 4A 4A F7 F7 F7 F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED EA EA EA B7 B7 B7 86 86 86 66 66 66 94 94 94 BF BF BF DA DA DA D7 D7 D7 B9 B9 B9 9E 9E 9E A0 A0 A0 A2 A2 A2 A0 A0 A0 8D 8D 8D 7A 7A 7A 66 66 66 6A 6A 6A 7C 7C 7C 94 94 94 AE AE AE B4 B4 B4 B4 B4 B4 B7 B7 B7 B9 B9 B9 BB BB BB BD BD BD C0 C0 C0 C2 C2 C2 BB BB BB A2 A2 A2 B4 B4 B4 89 89 89 4A 4A 4A 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 4C 4C 4C F5 F5 F5 F2 F2 F2 EF EF EF ED ED ED B9 B9 B9 77 77 77 66 66 66 94 94 94 D1 D1 D1 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 B7 B7 B7 9C 9C 9C 9E 9E 9E A0 A0 A0 A2 A2 A2 A5 A5 A5 A5 A5 A5 A2 A2 A2 94 94 94 80 80 80 6A 6A 6A 66 66 66 0 0 0 97 97 97 B0 B0 B0 B7 B7 B7 B9 B9 B9 BB BB BB BD BD BD C0 C0 C0 6B 75 6F 59 CC 80 56 A2 6F 77 77 77 4C 4C 4C 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 4E 4E 4E F2 F2 F2 E7 E7 E7 B2 B2 B2 77 77 77 6F 6F 6F A5 A5 A5 DA DA DA E0 E0 E0 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 E3 E3 E3 E3 E3 E3 C9 C9 C9 B7 B7 B7 A5 A5 A5 A2 A2 A2 A5 A5 A5 A5 A5 A5 A7 A7 A7 A9 A9 A9 AC AC AC 97 97 97 86 86 86 6F 6F 6F 66 66 66 75 75 75 94 94 94 B0 B0 B0 BB BB BB BD BD BD 65 78 6B 66 FF 99 59 CC 80 66 66 66 4E 4E 4E 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 6F 6F 6F AB AB AB 6F 6F 6F 77 77 77 B7 B7 B7 DD DD DD E3 E3 E3 E0 E0 E0 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 D7 D7 D7 EF EF EF ED ED ED EA EA EA EA EA EA EA EA EA D7 D7 D7 C2 C2 C2 B0 B0 B0 A5 A5 A5 A7 A7 A7 A9 A9 A9 AC AC AC AE AE AE B0 B0 B0 A2 A2 A2 8D 8D 8D 75 75 75 66 66 66 77 77 77 91 91 91 93 93 93 48 6F 55 52 78 5E 77 77 77 4E 4E 4E 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 79 79 79 5C 5C 5C 0 0 0 B9 B9 B9 E7 E7 E7 E5 E5 E5 E3 E3 E3 E0 E0 E0 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 CF CF CF E7 E7 E7 EF EF EF EF EF EF ED ED ED EA EA EA EA EA EA EA EA EA E9 E9 E9 E7 E7 E7 DE DE DE CF CF CF BF BF BF AE AE AE AC AC AC AE AE AE B0 B0 B0 B2 B2 B2 B4 B4 B4 AB AB AB 94 94 94 7C 7C 7C 66 66 66 70 70 70 8F 8F 8F 0 0 0 51 51 51 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 79 79 79 79 79 79 EA EA EA E7 E7 E7 E5 E5 E5 E3 E3 E3 E0 E0 E0 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 CF CF CF DD DD DD F1 F1 F1 EF EF EF AE AE AE A9 A9 A9 B9 B9 B9 CC CC CC E0 E0 E0 EA EA EA E9 E9 E9 E7 E7 E7 E7 E7 E7 E7 E7 E7 E5 E5 E5 DA DA DA C9 C9 C9 B9 B9 B9 B0 B0 B0 B2 B2 B2 B4 B4 B4 B4 B4 B4 B7 B7 B7 B4 B4 B4 9B 9B 9B 80 80 80 5E 5E 5E 53 53 53 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 7A 7A 7A E7 E7 E7 E5 E5 E5 E3 E3 E3 E0 E0 E0 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 CF CF CF D4 D4 D4 F1 F1 F1 F1 F1 F1 CA CA CA B9 B9 B9 EF EF EF DE DE DE C9 C9 C9 AE AE AE A2 A2 A2 B7 B7 B7 D1 D1 D1 E3 E3 E3 E7 E7 E7 E7 E7 E7 E5 E5 E5 E5 E5 E5 E5 E5 E5 E0 E0 E0 D2 D2 D2 C5 C5 C5 B9 B9 B9 B4 B4 B4 B7 B7 B7 B9 B9 B9 BB BB BB 89 89 89 54 54 54 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 7A 7A 7A E5 E5 E5 E3 E3 E3 E0 E0 E0 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 CF CF CF CF CF CF ED ED ED F2 F2 F2 D1 D1 D1 AB AB AB EA EA EA EF EF EF EF EF EF EF EF EF ED ED ED EA EA EA D7 D7 D7 C2 C2 C2 AE AE AE A9 A9 A9 BB BB BB CF CF CF E0 E0 E0 E5 E5 E5 E5 E5 E5 E3 E3 E3 E0 E0 E0 E0 E0 E0 D9 D9 D9 CC CC CC C2 C2 C2 B9 B9 B9 89 89 89 57 57 57 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A E3 E3 E3 E0 E0 E0 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 CF CF CF CF CF CF EF EF EF F5 F5 F5 D2 D2 D2 AB AB AB ED ED ED F1 F1 F1 F1 F1 F1 EF EF EF EF EF EF EF EF EF ED ED ED EA EA EA EA EA EA EA EA EA E5 E5 E5 CF CF CF BB BB BB A7 A7 A7 A7 A7 A7 BF BF BF D1 D1 D1 E3 E3 E3 E0 E0 E0 E0 E0 E0 E0 E0 E0 DE DE DE DD DD DD 97 97 97 59 59 59 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 7A 7A 7A D7 D7 D7 DD DD DD DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 CF CF CF CF CF CF EF EF EF F7 F7 F7 CC CC CC B0 B0 B0 EF EF EF F2 F2 F2 F2 F2 F2 F1 F1 F1 F1 F1 F1 EF EF EF EF EF EF EF EF EF ED ED ED EA EA EA EA EA EA EA EA EA E9 E9 E9 E7 E7 E7 E7 E7 E7 E0 E0 E0 CC CC CC B4 B4 B4 A2 A2 A2 AB AB AB BD BD BD D4 D4 D4 E0 E0 E0 DE DE DE 6C 6C 6C 69 69 69 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 63 63 63 8D 8D 8D DA DA DA D7 D7 D7 D4 D4 D4 D2 D2 D2 CF CF CF D4 D4 D4 F1 F1 F1 E0 E0 E0 B7 B7 B7 93 93 93 DA DA DA F5 F5 F5 F5 F5 F5 F2 F2 F2 F2 F2 F2 F1 F1 F1 F1 F1 F1 EF EF EF EF EF EF EF EF EF ED ED ED EA EA EA EA EA EA EA EA EA E9 E9 E9 E7 E7 E7 E7 E7 E7 E7 E7 E7 E5 E5 E5 E5 E5 E5 DA DA DA C6 C6 C6 99 99 99 DD DD DD B0 B0 B0 5E 5E 5E 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61 61 61 85 85 85 B7 B7 B7 CC CC CC CC CC CC D2 D2 D2 CA CA CA AE AE AE 93 93 93 7C 7C 7C 94 94 94 7C 7C 7C 6C 6C 6C 8A 8A 8A A5 A5 A5 BF BF BF E0 E0 E0 F1 F1 F1 F1 F1 F1 EF EF EF EF EF EF EF EF EF ED ED ED EA EA EA EA EA EA EA EA EA E9 E9 E9 E7 E7 E7 E7 E7 E7 E7 E7 E7 E5 E5 E5 E5 E5 E5 BF BF BF BD BD BD D9 D9 D9 66 66 66 86 86 86 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A 61 61 61 66 66 66 6A 6A 6A 85 85 85 A5 A5 A5 A5 A5 A5 C2 C2 C2 E0 E0 E0 C2 C2 C2 AC AC AC B0 B0 B0 AB AB AB 9E 9E 9E 91 91 91 7C 7C 7C 6F 6F 6F 89 89 89 AB AB AB C5 C5 C5 DD DD DD EF EF EF ED ED ED EA EA EA EA EA EA EA EA EA E9 E9 E9 E7 E7 E7 E7 E7 E7 E7 E7 E7 C9 C9 C9 AC AC AC DA DA DA 79 79 79 75 75 75 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 70 70 70 B9 B9 B9 EA EA EA EA EA EA EA EA EA EA EA EA C6 C6 C6 A7 A7 A7 AC AC AC B0 B0 B0 B4 B4 B4 B9 B9 B9 BD BD BD C0 C0 C0 B4 B4 B4 A5 A5 A5 93 93 93 7A 7A 7A 77 77 77 91 91 91 A9 A9 A9 CA CA CA E3 E3 E3 EA EA EA E9 E9 E9 E3 E3 E3 BB BB BB B7 B7 B7 D9 D9 D9 7A 7A 7A 75 75 75 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75 75 75 CF CF CF F2 F2 F2 F2 F2 F2 F2 F2 F2 F2 F2 F2 B4 B4 B4 A2 A2 A2 A7 A7 A7 AC AC AC B0 B0 B0 B4 B4 B4 B9 B9 B9 BD BD BD C0 C0 C0 C5 C5 C5 CA CA CA CF CF CF D4 D4 D4 BB BB BB A9 A9 A9 93 93 93 6C 6C 6C C5 C5 C5 C6 C6 C6 AE AE AE CF CF CF AE AE AE 6C 6C 6C 89 89 89 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6C 6C 6C E0 E0 E0 FA FA FA FD FD FD FF FF FF FF F9 F9 FF F2 F2 F2 F2 F2 E9 E9 E9 D4 D4 D4 C6 C6 C6 BF BF BF B4 B4 B4 B9 B9 B9 BD BD BD C0 C0 C0 C5 C5 C5 CA CA CA CF CF CF D4 D4 D4 D7 D7 D7 DD DD DD 7C 7C 7C 9E 9E 9E AE AE AE A0 A0 A0 6F 6F 6F 77 77 77 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7A 7A 7A A0 A0 A0 B9 B3 B3 C6 9B 97 FF AC 9F FF A6 99 FF A6 99 FF A6 99 FF BC B3 FF C7 BF FF D3 CC FF E9 E6 FF F9 F9 ED ED ED E5 E5 E5 DA DA DA D1 D1 D1 C9 C9 C9 CA CA CA CF CF CF D4 D4 D4 D7 D7 D7 66 66 66 73 73 73 83 83 83 A2 A2 A2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 88 75 75 B9 89 7B FF CF A7 FF CD A6 FF C4 A2 FF C0 9F FF BC 9D FF B7 9A FF B6 99 FF B6 99 FF B6 99 FF BB 9F FF C9 B3 FF D7 C6 FF E1 D2 FF EF E6 F8 F4 F2 F2 F2 F2 B8 B8 B8 7E 7E 7E 7D 7D 7D 0 0 0 0 0 0 0 0 0 0 0 0 70 70 70 70 70 70 70 70 70 70 70 70 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 96 79 79 CC 9F 8B FF D7 B0 FF D7 B0 FF D7 B0 FF D7 B0 FF D7 B0 FF D7 B0 FF D7 B0 FF D1 AA FF CF A7 FF CB A5 FF C9 A0 FF C8 9D FF C6 99 FF C6 99 FF C6 99 D2 9F 89 8E 8E 8E 83 83 83 81 81 81 0 0 0 0 0 0 70 70 70 60 60 60 20 20 20 10 10 10 10 10 10 10 10 10 20 20 20 60 60 60 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 91 6B 6B E6 BD A1 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF DA B5 FF D8 B2 FF D7 AE B3 82 78 80 80 80 81 81 81 0 0 0 0 0 0 60 60 60 20 20 20 10 10 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 10 10 20 20 20 60 60 60 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99 66 66 F9 D6 B6 FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB FF DD BB A6 75 71 0 0 0 0 0 0 0 0 0 60 60 60 20 20 20 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 1 1 1 20 20 20 60 60 60 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 A6 75 71 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 FF E0 C1 96 66 66 0 0 0 0 0 0 70 70 70 20 20 20 4 4 4 1 1 1 4 4 4 1C 1C 1C 24 24 24 1C 1C 1C 4 4 4 4 4 4 2 2 2 3 3 3 1 1 1 20 20 20 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9C 82 82 B9 8D 84 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 FF E3 C6 E6 C4 AE 91 6B 6B 0 0 0 0 0 0 60 60 60 14 14 14 11 11 11 4 4 4 19 19 19 9F 9F 9F D0 D0 D0 9F 9F 9F 30 30 30 1 1 1 0 0 0 1 1 1 0 0 0 10 10 10 60 60 60 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 91 6B 6B D2 AE 9F FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC FF E6 CC D2 AE 9F 9C 82 82 0 0 0 70 70 70 20 20 20 4 4 4 15 15 15 4 4 4 40 40 40 F1 F1 F1 E0 E0 E0 EF EF EF 9F 9F 9F 30 30 30 0 0 0 0 0 0 0 0 0 0 0 0 20 20 20 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99 66 66 F2 D8 C5 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 FF E8 D2 BF 97 8F 0 0 0 0 0 0 70 70 70 10 10 10 4 4 4 15 15 15 44 44 44 F1 F1 F1 9F 9F 9F 58 58 58 F1 F1 F1 EF EF EF 9F 9F 9F 30 30 30 0 0 0 0 0 0 0 0 0 10 10 10 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 A7 95 95 A6 77 74 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 FF EB D7 A6 77 74 0 0 0 0 0 0 70 70 70 10 10 10 4 4 4 35 35 35 9B 9B 9B 9F 9F 9F 30 30 30 0 0 0 40 40 40 F1 F1 F1 EF EF EF 9F 9F 9F 30 30 30 0 0 0 0 0 0 10 10 10 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 93 70 70 C6 A2 9A FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD FF EE DD EC D5 C7 93 70 70 0 0 0 0 0 0 70 70 70 10 10 10 4 4 4 12 12 12 24 24 24 18 18 18 0 0 0 0 0 0 0 0 0 40 40 40 F1 F1 F1 EF EF EF 9F 9F 9F 18 18 18 0 0 0 10 10 10 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 99 66 66 EC D7 CC FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 FF F1 E3 D2 B4 AC A7 95 95 0 0 0 0 0 0 70 70 70 20 20 20 0 0 0 4 4 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 40 40 40 F1 F1 F1 D7 D7 D7 20 20 20 0 0 0 20 20 20 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9C 82 82 A6 78 76 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 FF F4 E8 A2 77 75 0 0 0 0 0 0 0 0 0 0 0 0 60 60 60 10 10 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 40 40 40 A0 A0 A0 20 20 20 10 10 10 60 60 60 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 94 67 67 D9 C1 BB FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE FF F7 EE E6 D3 CC 97 77 77 0 0 0 0 0 0 0 0 0 0 0 0 70 70 70 20 20 20 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 20 20 0 0 0 20 20 20 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9C 82 82 AC 82 81 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 FF F9 F3 B3 8B 89 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 60 60 20 20 20 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 20 20 20 60 60 60 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9F 6F 6F EC E0 DD FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 FF FB F8 DF CC CA 99 7D 7D 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 60 60 60 20 20 20 10 10 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 10 10 20 20 20 60 60 60 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 97 68 68 B3 8C 8C CC B2 B1 CC B2 B1 D2 BB BB E6 D8 D7 E6 D8 D7 E6 D8 D7 F2 EB EA FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF EC E2 E1 9B 74 73 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 70 70 70 60 60 60 20 20 20 10 10 10 10 10 10 10 10 10 20 20 20 60 60 60 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 B6 AA AA B4 A8 A8 AF A2 A2 99 7F 7F 95 7C 7C 95 7C 7C 91 74 74 8F 69 69 8D 68 68 A1 83 83 A6 8A 8A B3 8C 8C B3 8C 8C B3 8C 8C 90 71 71 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 70 70 70 70 70 70 70 70 70 70 70 70 70 70 70 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 FF FF FF FF FF FF 0 0 FF FF FF FF FF FF 0 0 FF FF 87 E1 FF FF 0 0 FF FE 1 C0 7F FF 0 0 FF F8 0 0 F FF 0 0 FF F0 0 0 3 FF 0 0 FF C0 0 0 0 FF 0 0 FF 0 0 0 0 3F 0 0 FE 0 0 0 0 F 0 0 F8 0 0 0 0 F 0 0 F0 0 0 0 0 F 0 0 E0 0 0 0 40 1F 0 0 E0 0 0 0 0 1F 0 0 E0 0 0 0 0 1F 0 0 E0 0 0 0 0 1F 0 0 E0 0 0 2 0 1F 0 0 E0 0 0 0 0 1F 0 0 E0 0 0 0 0 1F 0 0 E4 0 0 0 0 5F 0 0 E0 0 0 0 0 1F 0 0 E0 0 0 0 0 1F 0 0 E0 0 0 0 0 1F 0 0 F0 0 0 0 0 1F 0 0 E0 0 0 0 0 1F 0 0 F0 0 0 0 0 3F 0 0 F8 0 0 0 0 3F 0 0 FC 0 0 0 0 7F 0 0 FF 80 0 0 0 FF 0 0 FF 80 0 0 1 FF 0 0 FF 80 0 0 7 FF 0 0 FF 80 0 0 1F FF 0 0 FF E0 0 0 F0 7F 0 0 FF E0 0 0 C0 1F 0 0 FF E0 0 1 80 F 0 0 FF E0 0 7 0 7 0 0 FF E0 0 6 0 3 0 0 FF C0 0 6 0 3 0 0 FF C0 0 4 0 1 0 0 FF C0 0 C 0 1 0 0 FF 80 0 C 0 1 0 0 FF 80 0 C 0 1 0 0 FF 80 0 C 0 1 0 0 FF 0 0 1E 0 3 0 0 FF 0 0 1E 0 3 0 0 FE 0 0 3F 0 7 0 0 FE 0 0 3F 80 F 0 0 FC 0 0 7F C0 1F 0 0 FF 80 0 FF F0 7F 0 0 </span>
<script language="VBScript" type="text/vbscript">
'***** Parameter ****
If(param<>"") then
if((inStr(param,"h")=1) Or (inStr(param,"?")=1) Or (inStr(2,param,"h")=2) Or (inStr(2,param,"?")=2)) then phflag=1:hilfe
if((inStr(param,"k")=1) Or (inStr(2,param,"k")=2)) then kflag=1
if((inStr(param,"l")=1) Or (inStr(2,param,"l")=2)) then DtopLink EigenerVollName,1
if((inStr(param,"d")=1) Or (inStr(2,param,"d")=2)) then DeInst:Window.close
end if
'**** Event-Handler starten
if deinstflag=0 then
eh="eventHandler"
document.onKeyDown = GetRef(eh)
'**** Script starten
if(hlpflag=0 And deinstflag=0) then startScript
end if
</script>
</body></html>
<! (C) CMDR 20080329>
#########################################################################
>>> standarddrucker.vbs <<<
'v4.7********************************************************
' File: standarddrucker.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Welcher ist der Standarddrucker?
'************************************************************
Option Explicit
Dim Text, KeyX, WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
KeyX = "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\Device"
Text = WshShell.RegRead( KeyX )
Text = Left ( Text, InStr( Text, ",")-1 )
MsgBox Text, , WScript.ScriptName
WScript.Quit
#########################################################################
>>> stoppuhr.vbs <<<
'*** v9.3 *** www.dieseyer.de *******************************
' File: TermineMelden.vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
'************************************************************
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Wss=WScript.CreateObject("WScript.Shell")
AktVerz=Fso.GetParentFolderName(WScript.ScriptFullName)
Titel=" Die Stopp - Uhr ! ! !"
UV=VbCR&VbCR 'MsgBox u.a. vereinfachen
' Die "Stoppen"-Datei in den Start-Ordner setzen :
'*************************************************
Datei1=AktVerz
' Prüfen, ob " Stoppen.vbs " bereits schon läuft :
'*************************************************
If Fso.FileExists (Datei1&"\Stoppen.vbs") then _
MsgBox UV&UV&VbTab&"Die StoppUhr läuft bereits ! "&_
" "&UV&UV,VbCritical,Titel:WScript.Quit
' Die Stopp - Uhr wird jetzt gestartet :
'***************************************
Ask=MsgBox (UV&UV&VbTab&_
"Mit dem Befehl "" OK "" startet die Messung ! "&UV&_
VbCR&VbTab&" Mit "" Stoppen.vbs "" die Uhr anhalten !"&_
UV&UV,VbOkCancel,Titel)
If Ask="2" then WScript.Quit
' Jetzt die Festlegung des Start - Zeitpunktes der Uhr :
'*******************************************************
Beginn=Timer
' " Stoppen.vbs " - Datei schreiben und in den Start-Ordner setzen :
'*******************************************************************
Set Ordner=Fso.GetFolder(Datei1)
Set Data=Ordner.CreateTextFile("Stoppen.vbs")
Data.WriteBlankLines(2)
Data.WriteLine("Start="&""""&Beginn&"""")
Data.WriteLine("UV=VbCR&VbCR")
Data.WriteLine("Set Fso=WScript.CreateObject(""Scripting.FileSystemObject"")")
Data.WriteLine("Datei="&""""&Datei1&"""&""\Stoppen.vbs"" ")
Data.WriteBlankLines(2)
Data.WriteLine("Ask=MsgBox(UV&VbCR&"" Wollen Sie nur eine Zwischenzeit""&_ ")
Data.WriteLine(" UV&"" oder die endgültige Zeit messen ?""&UV&_ ")
Data.WriteLine(" "" Bei """" OK """" kommt endgültige Zeit,""&UV&_ ")
Data.WriteLine(" "" bei """" Nein """" die Zwischenzeit ! ""&_ ")
Data.WriteLine(" "" ""&UV&UV,VbInformation+VbYesNoCancel, _ ")
Data.WriteLine(" "" Die gestoppte Laufzeit ! ! !"") ")
Data.WriteLine(" ")
Data.WriteLine("If Ask=""6"" then ")
Data.WriteLine(" MsgBox UV&UV&VbCR&""Die gestoppte Zeit beträgt ""&_ ")
Data.WriteLine(" Round(Timer-Start,2)&"" sec ""&_ ")
Data.WriteLine(" VbCR&UV&UV,VbInformation, _ ")
Data.WriteLine(" "" Die gestoppte Laufzeit ! ! !"" ")
Data.WriteLine("End If ")
Data.WriteLine(" ")
Data.WriteLine("If Ask=""7"" then ")
Data.WriteLine(" MsgBox UV&UV&VbCR&""Die gestoppte Zwischenzeit beträgt""&_ ")
Data.WriteLine(" "" ""&Round(Timer-Start,2)&"" sec ""&_ ")
Data.WriteLine(" VbCR&UV&UV,VbInformation, _ ")
Data.WriteLine(" "" Die Zwischen - Laufzeit ! ! !"" ")
Data.WriteLine(" WScript.Quit ")
Data.WriteLine("End If ")
Data.WriteLine(" ")
Data.WriteLine(" ")
Data.WriteLine("If Ask=""6"" then Fso.DeleteFile (Datei) ")
Data.WriteLine(" WScript.Quit ")
Data.Close
Datei1=Fso.GetParentFolderName(WScript.ScriptFullName)
Datei2=Datei1&"\Stoppen.vbs"
Wss.Run """"&Datei2&""""
WScript.Quit
#########################################################################
>>> stringanpositionindateitauschen.vbs <<<
'v3.1***********************************************************
' File: StringAnPositionInDateiTauschen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Ersetzt in jeder Zeile einer Datei Zeichen an einer Position.
'***************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, fso, FileIn, FileOut
Dim Datei, Text, Txt, i, arrSort, arrTest(), oArgs
Dim Aktion, Akt1, Akt2, SendToLink
Dim TxtParameter, TxtErsatz, TxtSonderz, TextNeu
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set oArgs = Wscript.Arguments
SendToLink = fso.GetBaseName( WScript.ScriptName )
'***************************************************************
' ANFANG - Das eigentliche Skript beginnt
'***************************************************************
TxtParameter = "Folgende Parameter sind möglich:" & vbCRLF
TxtParameter = TxtParameter & " l 10 " & vbTab & "ersetzt in jeder Zeile die " & vbCRLF
TxtParameter = TxtParameter & vbTab & vbTab & "ersten (linken) 10 Zeichen" & vbCRLF
TxtParameter = TxtParameter & " r 10 " & vbTab & "ersetzt in jeder Zeile die " & vbCRLF
TxtParameter = TxtParameter & vbTab & vbTab & "letzten (rechten) 10 Zeichen" & vbCRLF
TxtParameter = TxtParameter & " m 10 20 " & vbTab & "ersetzt in den Zeilen (mittendrin) " & vbCRLF
TxtParameter = TxtParameter & vbTab & vbTab & "die Zeichen an Pos. 10 bis 20 " & vbCRLF & vbCRLF
TxtErsatz = "Als ERSATZ sind beliebige Zeichen möglich:" & vbCRLF
TxtErsatz = TxtErsatz & "- wird kein Zeichen eingegeben, werden die " & vbCRLF
TxtErsatz = TxtErsatz & " (z.B. 10) Zeichen gelöscht." & vbCRLF
TxtErsatz = TxtErsatz & "- 3 Leerzeichen ("" "") ersetzen (z.B.10) Zeichen." & vbCRLF & vbCRLF
TxtSonderz = "Folgende Sonderzeichen sind nur einzeln als ERSATZ einsetzbar: " & vbCRLF
TxtSonderz = TxtSonderz & " vbCRLF" & vbTab & "neue Zeile (bzw. vbLF / vbCR)" & vbCRLF
TxtSonderz = TxtSonderz & " vbTab " & vbTab & "Tabulator" & vbCRLF
TxtSonderz = TxtSonderz & " vbNullChar" & vbTab & "ein NULL-Zeichen Chr(0)," & vbCRLF
TxtSonderz = TxtSonderz & vbTab & vbTab & "also kein! Leerschritt" & vbCRLF
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
If oArgs.Count = 2 then SkriptInfo ' SUB Aufruf
If oArgs.Count > 4 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Aktion = "---"
Akt1 = 0
Akt2 = 0
If oArgs.Count = 1 then
Datei = oArgs.item(1-1) ' #X#~-_-~#X#
if not fso.FileExists( Datei ) then
Text = "Die Datei " & Datei & " existiert nicht!"
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende." , 64
WScript.Quit
End If
Else
Akt1 = oArgs.item(3-1) ' #X#~-_-~#X#
Aktion = oArgs.item(2-1) ' #X#~-_-~#X#
Datei = oArgs.item(1-1) ' #X#~-_-~#X#
Aktion = UCase( Aktion )
End If
Akt1 = CInt( Akt1 )
If oArgs.Count = 4 then ' vier Param.? - das muss Datei und "m 10 20" sein
Akt2 = oArgs.item(4-1) ' #X#~-_-~#X#
Akt2 = CInt( Akt2 )
if Aktion = "M" AND Akt2 >= Akt1 AND Akt1 > 0 then Mittendrin ' Sub Aufruf
' ~~~ ~~~ ~~~
End If
if Aktion = "L" then Links ' Sub Aufruf
if Aktion = "R" then Rechts ' Sub Aufruf
' wurde nur eine Datei (Drag & Drop) übergeben, müssen die parameter erfragt werden
Text = UCase ( Datei) & " soll bearbeitet werden. " & vbCRLF & vbCRLF
Text = Text & TxtParameter & TxtErsatz & TxtSonderz
Text = InputBox( Text, WScript.ScriptName)
' ~~~~~~~~
Txt = UCase( Left( Text, 2)) ' die linken zwei Zeichen
if Txt = "L " then Aktion = UCase( Left( Txt, 1))
if Txt = "R " then Aktion = UCase( Left( Txt, 1))
if Txt = "M " then Aktion = UCase( Left( Txt, 1))
Text = UCase( Mid( Text, 3)) ' die Zeichen nach den ersten beiden
if 0 = InStr (Text, " " ) then Akt1 = Cint(Text) ' es gibt nur einen Parameter
if not 0 = InStr (Text, " " ) then ' es gibt mehrer Parameter
if Len( Text) > InStr( Text, " " ) then
Akt1 = Left( Text, InStr (Text, " " ) -1)
Akt1 = CInt( Akt1 )
Text = UCase( Mid( Text, InStr (Text, " " ) +1)) ' den nächsten Parameter
if 0 = InStr (Text, " " ) then Akt2 = Text ' es gibt nur einen weiteren Parameter
if not 0 = InStr (Text, " " ) then ' es gibt mehrer weiteren Parameter
Akt2 = Left( Text, InStr (Text, " " ) -1)
Akt2 = CInt( Akt2 )
End If
End If
End If
' MsgBox Aktion & vbCRLF & Akt1 & vbCRLF & Akt2 & vbCRLF & Datei, , "Aktion Akt1 Akt2 Datei"
if Aktion = "L" then Links ' Sub Aufruf
if Aktion = "R" then Rechts ' Sub Aufruf
if Aktion = "M" then
if akt1 < akt2 then Mittendrin ' Sub Aufruf
End If
Text = "Das waren: Keine VERNÜNFTIGEN Eingaben!" & vbCRLF & vbCRLF
Text = Text & Aktion & " " & akt1 & " " & akt2
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende." , 64
WScript.Quit
'***************************************************************
' ENDE - Das eigentliche Skript beginnt (SUB'S weiter unten)
'***************************************************************
Sub SendenAnLink ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
End Sub ' SendenAnLink
Sub SkriptInfo ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
Text = Text & "Das Ganze funktioniert so:" & vbCRLF
Text = Text & " Eine Datei mit der Maus auf das Skript ziehen " & vbCRLF
Text = Text & " und fallen lassen ODER dem Skript über " & vbCRLF
Text = Text & " 'Senden an' die Datei übergeben. " & vbCRLF & vbCRLF
Text = Text & TxtParameter & TxtErsatz & TxtSonderz
MsgBox Text, , "WScript.Quit"
WScript.Quit
End Sub ' SkriptInfo
Sub Links ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "Links >" & Aktion & "< >" & Akt1 & "< >" & Akt2 & "<", , "WScript.Quit"
Text = "In der Datei " & UCase(Datei) & " sollen die linken (ersten) Zeichen bis zum Zeichen "
Text = Text & Akt1 & " ersetzt werden. " & vbCRLF & vbCRLF
Text = Text & TxtErsatz & TxtSonderz & vbCRLF
Text = Text & "Wie lauten die Ersatz-Zeichen?"
TextNeu = Ersatz ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
Datei = Datei & ".txt"
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Schreiben öffnen
FileOut.Writeline ( WScript.ScriptName & " " & Aktion &" " & Akt1 ) ' eine Zeile schreiben
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zuende ist, weiter machen
i = i + 1
Text = FileIn.Readline ' eine Zeile lesen
if Len( Text ) >= CInt(Akt1) then
Text = TextNeu & Mid ( Text , CInt(Akt1) +1 )
Else
Text = TextNeu
End If
FileOut.Writeline (Text) ' eine Zeile schreiben
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.Run Datei
WScript.Quit
End Sub ' Links
Sub Rechts ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "Rechts >" & Aktion & "< >" & Akt1 & "< >" & Akt2 & "<", , "WScript.Quit"
Text = "In der Datei " & UCase(Datei) & " sollen alle! Zeichen ab dem Zeichen "
Text = Text & Akt1 & " (inkl. Zeichen " & Akt1 & ") ersetzt werden. " & vbCRLF & vbCRLF
Text = Text & TxtErsatz & TxtSonderz & vbCRLF
Text = Text & "Wie lauten die Ersatz-Zeichen?"
TextNeu = Ersatz ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
Datei = Datei & ".txt"
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Schreiben öffnen
FileOut.Writeline ( WScript.ScriptName & " " & Aktion &" " & Akt1 ) ' eine Zeile schreiben
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zuende ist, weiter machen
i = i + 1
Text = FileIn.Readline ' eine Zeile lesen
if Len( Text ) >= CInt(Akt1) then
Text = Mid ( Text , 1, CInt(Akt1) -1 ) & TextNeu
' Else
' Text = ""
End If
FileOut.Writeline (Text) ' eine Zeile schreiben
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.Run Datei
WScript.Quit
End Sub ' Rechts
Sub Mittendrin ' Sub Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "MittenDrin >" & Aktion & "< >" & Akt1 & "< >" & Akt2 & "<", , "WScript.Quit"
Text = "In der Datei " & UCase(Datei) & " sollen die Zeichen von "
Text = Text & Akt1 & " bis " & Akt2 & " ersetzt werden. " & vbCRLF & vbCRLF
Text = Text & TxtErsatz & TxtSonderz & vbCRLF
Text = Text & "Wie lauten die Ersatz-Zeichen?"
TextNeu = Ersatz ' Sub Aufruf
'~~~~~~~~~~~~~~~~~~
Set FileIn = FSO.OpenTextFile(Datei, 1 ) ' Datei zum Lesen öffnen
Datei = Datei & ".txt"
Set FileOut = FSO.OpenTextFile(Datei, 2, true) ' Datei zum Schreiben öffnen
FileOut.Writeline ( WScript.ScriptName & " " & Aktion &" " & Akt1 & " " & Akt2 ) ' eine Zeile schreiben
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zuende ist, weiter machen
i = i + 1
Text = FileIn.Readline ' eine Zeile lesen
if Len( Text ) >= CInt(Akt2) then
Text = Mid ( Text , 1, CInt(Akt1) -1 ) & TextNeu & Mid ( Text , CInt(Akt2) +1 )
Else
if Len( Text ) >= CInt(Akt1) then
Text = Mid ( Text , 1, CInt(Akt1) -1 ) & TextNeu
End If
End If
FileOut.Writeline (Text) ' eine Zeile schreiben
Loop
FileIn.Close
Set FileIn = nothing
FileOut.Close
Set FileOut = nothing
WSHShell.Run Datei
WScript.Quit
End Sub ' Mittendrin
Function Ersatz ' Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ersatz = InputBox( Text, WScript.ScriptName)
if UCase(Ersatz) = UCase("vbCRLF" ) then Ersatz = Chr(13) & Chr(10)
if UCase(Ersatz) = UCase("vbCR" ) then Ersatz = Chr(13)
if UCase(Ersatz) = UCase("vbLF" ) then Ersatz = Chr(10)
if UCase(Ersatz) = UCase("vbTab" ) then Ersatz = Chr(9)
if UCase(Ersatz) = UCase("vbNullChar" ) then Ersatz = Chr(0)
End Function ' Ersatz
#########################################################################
>>> stringindatei-1.vbs <<<
'v7.9*****************************************************
' File: dateienvergleich-1.vbs
' Autor: W. Schmelz
' http://dieseyer.de
'
' Beliebige Datei auf dieses Programm ziehen und loslassen!
' Ein zu suchendes Wort eingeben, groß und klein wichtig !!
' Die Zeilen mit dem gesuchten Wort werden dann mit der Num-
' merierung angezeigt!
'****************************************************
' CopyRight W. Schmelz, 09.08.2007
'Objekte für das Programm bereit stellen:
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Arg=Wscript.Arguments
Titel=" Wort in Datei suchen !"
'Aufgesetzte Datei ermitteln:
For i=0 to Arg.Count -1
Datei=Arg.Item(i)
Next
'Falls keine Datei aufgesetzt wurde:
UV=VbCR&VbCR
If Datei="" then MsgBox UV&VbCR&_
" Bitte eine Datei aufsetzen,"&UV&_
" in der Wort gesucht werden soll ! "&_
UV&VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Abfrage des zu suchenden Wortes oder Abbruch:
Wort=InputBox(UV&UV&_
" Geben Sie das zu suchende Wort ein !"&UV&_
" Achten Sie auf kleine / große Buchstaben !"&UV&UV,Titel)
If Wort="" then WScript.Quit
'Aufgesetzte Datei öffnen und lesen:
Set File=Fso.OpenTextFile(Datei,1,true)
i=1
Do until File.AtEndOfStream
ReDim Preserve Zeile(i)
Zeile(i)=File.ReadLine
i=i+1
Loop
Ende=i-1
File.Close
Set File=Nothing
'Suche des Wortes in den Zeilen:
Hier=""
Zahl="0" 'Zahl der Fundstellen
For i=1 to Ende
k=1
Do until k>Len(Zeile(i))-Len(Wort)+1
If Mid(Zeile(i),k,Len(Wort))=Wort then
Hier=Hier&" | "&i
Zahl=Zahl+1 'Wie oft "Wort" gefunden ?
End If
k=k+1
Loop
Next
'Ende abschneiden !
If Len(Hier)>4 then Hier=Right(Hier,Int(Len(Hier)-3))
'Falls nichts zu finden war:
If Hier="" then MsgBox UV&VbCR&"Das Wort "" "&_
Wort&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Zeilen mit Nr. versehen:
For i=1 to Ende
Zeile(i)=i&VbTab&Zeile(i) 'VbTab gibt spaltenweise Anzeige, nicht " "!
Next
'Ausgabe der Fundstellen:
'MsgBox UV&UV&" Das Wort "" "&Wort&_
' " "" befindet sich in Zeile : "&UV&UV&_
' " "&Hier&UV&UV,VbInformation,Titel
'Aufsplittung der Fundorte in Ort( ), beginnt mit Ort(0) !
Ort=Split(Hier," | ")
'Ausgabedatei festlegen und gefundene Zeilen mit Nr. hinein schreiben:
Stamm=Fso.GetParentFolderName(Datei)
Datei=Fso.GetBaseName(Datei)&"-Such.txt"
Datei=Stamm&"/"&Datei
Set File=Fso.OpenTextFile(Datei,2,true)
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine("Das Wort "" "&Wort&" "" steht in folgenden Zeilen:")
File.WriteLine("************************************************")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
i=0
Do until i=Zahl 'Beginn mit i=0 !!
File.WriteLine(" ")
File.WriteLine(Zeile(Ort(i)))
i=i+1
Loop
File.Close
Set File=Nothing
'Bei Erfolg die Datei mit den Zeilen-Nr. anzeigen und diese löschen:
Wss.Run "Notepad """&Datei&""" "
WScript.Sleep 1500
'Frage, ob Ausgabe-Datei gelöscht werden soll:
Ask=MsgBox(UV&UV&_
"Soll diese Datei mit den Fundorten gelöscht werden ? "&_
UV&"Sie steht im Verzeichnis dieser aufgesetzten Datei!"&UV&_
UV,VbYesNo+VbDefaultButton2+VbCritical,Titel)
If Ask="7" then WScript.Quit ' Bei "Nein" Abbruch !
'Sonst die Fundort-Datei löschen:
WScript.Sleep 1000
Fso.DeleteFile Datei
#########################################################################
>>> stringindatei.vbs <<<
'v3.6*****************************************************
' File: StringInDatei.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Script sucht in einer Datei nach einer Zeichenkette und
' speichert jede Zeile, die diese Zeichenkette enthält, mit
' Zeilennummer in eine andere Datei.
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell, FSO, FileIn, FileOut
Dim EingDatei, Ausgdatei, ZKette, Zeile, Antwort, i
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
EingDatei = "error.log"
AusgDatei = "fehler.log"
ZKette = "msgbox"
ZKette = InputBox ("Nach welcher Zeichenkette soll in einer Datei gesucht werden?", WScript.ScriptName, ZKette)
If ZKette = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, WScript.ScriptName, 64
WScript.Quit
End If
EingDatei = InputBox ("Welche Datei soll nach '" & ZKette & "' durchsucht werden?", WScript.ScriptName, EingDatei)
If EingDatei = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, WScript.ScriptName, 64
WScript.Quit
End If
if not fso.FileExists(EingDatei) Then
WSHShell.Popup (EingDatei & "existiert nicht. Zur Demo wird dieses Skript " & WScript.ScriptName & " nach " & EingDatei & " kopiert."), 3, WScript.ScriptName, 64
FSO.CopyFile WScript.ScriptName, EingDatei ' fals Datei nicht vorhanden, dieses Script nach error.log kopieren - zum Testen
End If
if not fso.FileExists(EingDatei) Then ' fals Datei nicht vorhanden
MsgBox "Datei " & EingDatei & " zum Einlesen fehlt.", , WScript.ScriptName
WScript.Quit
End If
AusgDatei = InputBox ("In welche Datei sollen die Zeilen mit der Zeichenkette" & vbCRLF & "'" & ZKette & "'" & vbCRLF & "gespeichert werden?", WScript.ScriptName, AusgDatei)
If AusgDatei = "" then
WSHShell.Popup (". . . denn eben nicht!"), 3, WScript.ScriptName, 64
WScript.Quit
End If
if fso.FileExists(AusgDatei) Then
Antwort = MsgBox (AusgDatei & " existiert bereits - soll sie gelöscht werden?", 4+32+256, WScript.ScriptName)
If Antwort = vbYes then fso.DeleteFile(AusgDatei), True
End If
Set FileIn = FSO.OpenTextFile(EingDatei, 1 ) ' Datei zum Lesen öffnen
Set FileOut = fso.OpenTextFile(AusgDatei, 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
fileOut.WriteLine( vbCRLF & now() & vbTab & "Zeichenkette '" & ZKette & "' gefunden in Zeile(n):")
i=0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
i = i + 1
Zeile = FileIn.Readline ' eine Zeile lesen
If InStrRev( UCase( Zeile), UCase( ZKette)) > 0 Then fileOut.WriteLine(i & vbTab & ":" & Zeile)
' InStrRev(..) sucht von hinten, ob Zeichenfolge vorhanden
' ist und gibt die Position des ersten Auftretens zurück -
' wenn die Positon größer als 1, wird die Zeile in die
' Ausgabedatei geschrieben
' If InStr(TextU, ZKette) > 0 Then fileOut.WriteLine(i & vbTab & TextU)
' InStr(..) sucht von vorn, . . .
Loop
FileIn.Close
Set FileIn = Nothing ' Datei schließen
FileOunt.Close
Set FileOut = Nothing ' Datei schließen
WSHShell.Run AusgDatei
' WSHShell.Run "Notepad.exe " & AusgDatei
#########################################################################
>>> stringindateitauschen.vbs <<<
'v2.7********************************************************
' File: StringInDateiTauschen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' In den Zeilen dürfen keine Anführungszeichen " stehen!
'
' dateiliste.txt stellt eine Liste der zu prüfenden Dateien
' bereit. Beim Skriptaufruf wird nach der zu suchenden
' Zeichenkette gefragt. Diese wird bei der Abfrage, wie die
' Zeichenkette zukünftig aussehen soll angezeigt und
' kann geändert werden.
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso, fo, fi, FinList, Fin, Fout
Dim Ziel, Quelle, WSHShell, ZielVerz
Dim TextX, Text1, Text2, Text3, Txt(), i, i1
Dim aHTML, eHTML, StringAlt, StringNeu, iText, DateiListe
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
ZielVerz = "m:\dieseyer.test"
ZielVerz = fso.GetParentFolderName( WScript.ScriptFullName )
DateiListe = ZielVerz & "\dateiliste.txt"
If not fso.FileExists( DateiListe ) Then MsgBox DateiListe & " existiert nicht!", , WSCript.ScriptName
If not fso.FileExists( DateiListe ) Then WScript.Quit
'---------------------------------------------------------
' DateiListe zeilenweise lesen (für Anzeige)
'---------------------------------------------------------
iText = ""
Set FinList = FSO.OpenTextFile( DateiListe, 1 ) ' Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
Text1 = Text1 & vbCRLF & " " & TextX
End If
Loop
FinList.Close
Set FinList = nothing
TextX = ""
TextX = TextX & "In folgenden Dateien werden Zeichenketten ausgetauscht:" & vbCRLF
TextX = TextX & Text1
i = MsgBox (TextX, 4 + 32 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text1 = Text1 & "Wie lautet die Zeichenfolge (StringAlt), die erstezt werden soll?"
StringAlt = InputBox ( Text1 , WSCript.ScriptName , StringAlt)
If StringAlt = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
Text1 = ""
Text1 = Text1 & "Folgende Zeichenfolge (StringAlt) soll in den soeben gezeigten Dateien ausgetauscht werden."
Text1 = Text1 & "Ändern Sie jetzt diese Zeichenkette, um festzulegen, wie die Zeichenkette in Zukunft (StringNeu) aussehen soll."
StringNeu = InputBox ( Text1 , WSCript.ScriptName , StringAlt)
If StringNeu = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
If StringAlt = StringNeu then
WSHShell.PopUp "Wenn StringNeu" & vbCRLF & " " & StringNeu & vbCRLF & "und StringAlt" & vbCRLF & " " & StringAlt & vbCRLF & "gleich sind, wird's nichts!", , WScript.Scriptname
WSCript.Quit
End If
TextX = "DAS IST DIE LETZTE WARNUNG!" & vbCRLF & vbCRLF & TextX
i = MsgBox (TextX, 4 + 48 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text2 = ""
'---------------------------------------------------------
' DateiListe zeilenweise lesen & Zeichenkette(n) tauschen
'---------------------------------------------------------
Set FinList = FSO.OpenTextFile( DateiListe, 1 ) ' DateiListe-Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn DateiListe-Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
If not Text2 = "" then
Text1 = Text1 & vbCRLF & TextX & vbTab & " übersprungen"
Else
' MsgBox textx
Text3 = StringInDateiTauschen( TextX, StringAlt, StringNeu) ' Function Aufruf
if vbcancel = WSHShell.Popup (TextX & " . . . wurde bearbeitet.", 1, WScript.ScriptName, 1 + 64 ) Then Text2 = "übergehen"
Text1 = Text1 & vbCRLF & TextX & Text3
' Text1 = Text1 & vbCRLF & TextX & i
End If
End If
Loop
FinList.Close
Set FinList = nothing
MsgBox Text1, , WScript.ScriptName
WScript.Quit
Function StringInDateiTauschen (Datei, Suchen, Ersetzen)
Dim FileContents, dFileContents
if not WScript.CreateObject("Scripting.FileSystemObject").FileExists(Datei) then WScript.CreateObject("WScript.Shell").PopUp "Datei nicht gefunden!", 15, WScript.Scriptname
if not WScript.CreateObject("Scripting.FileSystemObject").FileExists(Datei) then Exit Function
FileContents = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(Datei).ReadAll ' Datei einlesen
dFileContents = Replace(FileContents, Suchen, Ersetzen, 1, -1, 1) ' Ersetze alle Strings im Quellfile
If dFileContents <> FileContents Then ' Vergleiche Quelle und Ergebnis
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(Datei, 2, True).Write dFileContents ' Schreibe Ergebnis wenn Unterschied besteht
' WScript.CreateObject("WScript.Shell").PopUp "Austausch in Datei """ & Datei & """ abgeschlossen " , 1, WSCript.ScriptName, vbExclamation
Else
' WScript.CreateObject("WScript.Shell").PopUp "Der angegebene String ==|" & Suchen & "|== konnte nicht in der Datei """ & Datei & """ gefunden werden." , 5, WSCript.ScriptName, vbExclamation
End If
End Function ' StringInDateiTauschen
#########################################################################
>>> suchmaschine.vbs <<<
'*** v8.8 *** www.dieseyer.de ******************************
'
' Datei: Suchmaschine.vbs
' Autor: W.Schmelz
' Auf: www.dieseyer.de
'
'In der Datei "GrdProbl.txt" wird gleich ein eingegebener
'Begriff gesucht - oder 2 durch Komma getrennte, eingebene
'Worte. Bei nur einer Fundstelle wird der Inhalt des ein-
'zigen gefundenen Abschnitt in einer Hilfs-Datei angezeigt,
'die gelöscht wird! Bei mehreren Fundstellen werden diese
'zunächst alle genannt. Es ist dann möglich, die erste ge-
'fundene auszugeben, eine ausgesuchte oder alle hinterein-
'ander weg gesetzt! Von allen weiteren Fundstellen werden
'am Ende die Namen genannt!
'
'Bei mehr als 10 Funden wird die erste Fundstelle gezeigt!
'
'Die Fundstellen werden mit 11111 bzw. 22222 markiert !
'***********************************************************
'CopyRight W. Schmelz, 19.07.2008
'Die Objekte u. a. werden für das Programm bereit gestellt:
'**********************************************************
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Arg=Wscript.Arguments
Dim Ende, Zahl, Zahl1, Zahl2, Hier, Hier1, Hier2, Word, Nr()
Dim Fund, Start1(), Start2(), Zeile(), Datei, Beginn, Letzte
Dim Zwei, Titel, UV, Schluss, ZahlR, Ask, NochNr(), Rest
Dim Neu, Stelle
Titel=" Begriffe in GrdProbl.txt suchen"
Datei="GrdProbl.txt"
UV=VbCR&VbCR
'Namen des Startordner suchen:
'*****************************
AktVerz=Fso.GetParentFolderName(WScript.ScriptFullName)
'Prüfen, ob "GrdProbl.txt" im Ordner enthalten:
'**********************************************
If not Fso.FileExists(AktVerz&"\GrdProbl.txt") then _
MsgBox UV&VbCR&"Im Ordner "&_
"ist ""GrdProbl.txt"" nicht enthalten ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Die Abfrage der zu suchenden Begriffe - oder ein Abbruch:
'*********************************************************
Word=InputBox(UV&_
" Geben Sie den zu suchenden Begriff ein !"&UV&_
" Große und kleine Buchstaben sind egal !"&UV&_
" GrdProbl.txt wird auf den Begriff abgesucht!"&UV&_
" Der erste gefundene Abschnitt wird ange-"&UV&_
" zeigt, die Nummern der weiteren genannt !"&UV&_
" Erste Fundstelle, bestimmte, alle einsehbar !"&UV&_
" Die Fundzeilen sind mit Zeichen markiert !"&UV&_
" Sogar zwei Worte mit "" , "" sind möglich !!"&_
UV,Titel,"Run,Notepad")
Word=LCase(Word)
If Word="" then WScript.Quit
'Die evtl. eingetragenen Leerstellen beseitigen,
'denn sie könnten bei der Suche Probleme geben !
'***********************************************
Neu=""
For i=1 to Len(Word)
Stelle=Mid(Word,i,1)
If not Stelle=" " then Neu=Neu&Stelle
Next
Word=Neu
'Die evtl. eingetragenen Leerstellen beseitigen,
'denn sie könnten bei der Suche Probleme geben !
'***********************************************
Neu=""
For i=1 to Len(Word)
Stelle=Mid(Word,i,1)
If not Stelle=" " then Neu=Neu&Stelle
Next
Word=Neu
'Prüfen, ob zuviele Worte eingetragen wurden:
'********************************************
N1="0" 'Zahl der Kommata prüfen
For i=1 to Len(Word)
If Mid(Word,i,1)="," then N1=1+N1
Next
'Abbruch, wenn mehr als ein Komma vorkommt:
'******************************************
If N1>1 then MsgBox UV&VbCR&"In der Eingabe "&_
"sind zuviele Kommata ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Eine oder zwei Eingaben?
'************************
Zwei="0"
For i=1 to Len(Word)
If Mid(Word,i,1)="," then Zwei="1"
Next
'Die Eingabe ggf. aufsplitten in Wort(0)und Wort(1):
'***************************************************
Wort=Split(Word,",")
'Abbruch, wenn Wort(1)="" oder nur 1 Buchstabe hat:
'**************************************************
If Zwei="1" then
If (Wort(1)="" or Len(Wort(1))=1) then MsgBox UV&VbCR&_
"Das zweite Wort "&_
"war leer oder sinnlos ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
End If
'Die Datei "GrdProbl.txt" öffnen und lesen:
'******************************************
Set File=Fso.OpenTextFile(Datei,1,true)
i=1
Do until File.AtEndOfStream
ReDim Preserve Zeile(i)
Zeile(i)=File.ReadLine
i=i+1
Loop
Ende=i-1
File.Close
Set File=Nothing
'***********************************************
'Inhaltsverzeichnis ist nicht mit zu betrachten,
'Zeile(i) erst ab "############ . . . " rechnen:
'***********************************************
i=1
Do until i>Ende
If Left(Zeile(i),3)="###" then Beginn=i
i=i+1
Loop
'Erst mit "Beginn" wird die Zeilenbetrachtung gestartet! s.u.
'Schlusszeichen der Zeilen bis dahin ermitteln:
'**********************************************
ReDim Preserve Nr(Ende)
k=1
Do until k>Beginn
Nr(k)=Right(Zeile(k),1)
k=k+1
Loop
'Die größte Abschnittnummer des Inhaltsverzeichnis ermitteln:
'************************************************************
Schluss="1" 'Größte Abschnittnummer!
x=1
Do until x>Beginn
If (Asc(Nr(x))>47 and Asc(Nr(x))<58) then 'nur Zahlen nehmen
If Right(Zeile(x),3)>=Schluss then Schluss=Right(Zeile(x),3)
End If
x=x+1
Loop
'Die Zeilen jetzt ab " Beginn " neu nummerieren:
'***********************************************
k=1
Do until k>Ende-Beginn
Zeile(k)=Zeile(Beginn+k)
k=k+1
Loop
'Die Suche des Begriffes 1 in den neu benannten Zeilen:
'******************************************************
Hier1=""
Zahl1="0" 'Zahl der Fundstellen
For i=1 to Ende
k=1
Do until k>Len(Zeile(i))-Len(Wort(0))+1
If LCase(Mid(Zeile(i),k,Len(Wort(0))))=Wort(0) then
If Len(Hier1)>0 then Hier1=Hier1&"|"&i
If Hier1="" then Hier1=i
Zahl1=Zahl1+1 'Wie oft "Wort(0)" gefunden ?
End If
k=k+1
Loop
Next
'Der Abbruch - falls nichts zu finden war:
'*****************************************
If Hier1="" then MsgBox UV&VbCR&"Der Begriff "" "&_
Wort(0)&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Die Aufsplittung der Fundorte in Ort1(i), erster ist Ort1(0):
'*************************************************************
Ort1=Split(Hier1,"|")
'Die Fundstellen für Wort1 werden markiert:
'******************************************
i=0
Do until i=Zahl1
'Wenn noch nicht markiert:
If not Right(Zeile(Ort1(i)),5)="11111" then
Zeile(Ort1(i))=Zeile(Ort1(i))&" 1111111111"
End If
i=i+1
Loop
'Die Startzeile der Abschnitte suchen:
'*************************************
ReDim Preserve Start1(Zahl1+1)
a=0
Do until a=Zahl1
Start1(a)=Ort1(a) 'Anfang setzen und rückwärts gehen
k=1
Do until (Zeile(Start1(a))="" and Zeile(Start1(a)-1)="" and _
Zeile(Start1(a)-2)="" and Zeile(Start1(a)-3)="")
Start1(a)=Ort1(a)-k
k=k+1
Loop
Start1(a)=Start1(a)+1
a=a+1
Loop
'Die Nummern der Abschnitte ermitteln:
'*************************************
b=1
Do until b=Zahl1
Ort1(b)=Left(Zeile(Start1(b)),3)
b=b+1
Loop
Fund=Left(Zeile(Start1(0)),3) 'Nr. des 1. Fundortes
Ort1(0)=Left(Zeile(Start1(0)),3) 'Zeile von diesem
'******************************************************
'Bei zwei Begriffen die gemeinsamen Fundorte ermitteln!
'Am Ende wird so bezeichnet wie bei nur einem Begriff,
'damit die Ausgabe so erfolgt wie bei einem Begriff ! !
'******************************************************
If Zwei="1" then Doppel
'Namen des Startordner suchen, Ausgabedatei benennen:
'****************************************************
Stamm=Fso.GetParentFolderName(Datei)
DateiN=Fso.GetBaseName(Datei)&"-Such.txt"
AktVerz=Replace(Datei,Fso.GetFileName(Datei),"")
Datei=AktVerz&DateiN
'Gefundene Abschnitts-Nr. auflisten:
'***********************************
Rest=Fund
k=1
Do until k=Zahl1
If (Ort1(k)<>Fund and Letzte<>Ort1(k)) then
Rest=Rest&"|"&Ort1(k)
Letzte=Ort1(k)
End If
If Ort1(k)=Schluss then k=Zahl1-1 'Abbruch am letzten Abschnitt
k=k+1
Loop
'Falls mehr als eine Fundstelle da ist:
'**************************************
If Len(Rest)>3 then '<<<<<<<<<<<<<<<<<<
Rest=Right(Rest,Len(Rest)-4) 'Restliche Fundorte
ZahlR="1" 'Die Anzahl der restlichen Fundorte:
For i=1 to Len(Rest)
If Mid(Rest,i,1)="|" then ZahlR=1+ZahlR
Next
'Die weiteren, gefundenen Abschnitte aufsplitten, Noch(0) usw.:
'**************************************************************
Noch=Split(Rest,"|")
'Deren Überschriften auflisten in Txt:
'*************************************
For i=1 to Ende
For k=1 to ZahlR
ReDim Preserve NochNr(k)
If Left(Zeile(i),3)=Noch(k-1) then
NochNr(k)=i
If (Right(Zeile(NochNr(k)),23)="1111111111 2222222222" or _
Right(Zeile(NochNr(k)),23)="2222222222 1111111111") then
Txt=Txt&VbCR&k+1&") "&Left(Zeile(NochNr(k)),Len(Zeile(NochNr(k)))-23)
ElseIf (Right(Zeile(NochNr(k)),5)="11111" or _
Right(Zeile(NochNr(k)),5)="22222") then
Txt=Txt&VbCR&k+1&") "&Left(Zeile(NochNr(k)),Len(Zeile(NochNr(k)))-13)
Else
Txt=Txt&VbCR&k+1&") "&Zeile(NochNr(k))
End If
End If
Next
Next
'*****************************************************************
' Für mehr als einen, aber bis 10 Fundstellen, die Möglichkeit er-
' öffnen, alle Abschnitte einzeln anzuzeigen - oder nur bestimmten
'*****************************************************************
If ZahlR<=9 then 'Zahl der zusätzlichen Fundstellen
'Ihre Liste bilden:
'******************
If (Right(Zeile(Start1(0)),23)="1111111111 2222222222" or _
Right(Zeile(Start1(0)),23)="2222222222 1111111111") then
Txt1=Left(Zeile(Start1(0)),Len(Zeile(Start1(0)))-23)
ElseIf (Right(Zeile(Start1(0)),5)="11111" or _
Right(Zeile(Start1(0)),5)="22222") then
Txt1=Left(Zeile(Start1(0)),Len(Zeile(Start1(0)))-13)
Else
Txt1=Zeile(Start1(0))
End If
'Nachfrage, was als Ausgabe gewünscht wird:
'******************************************
Ask=InputBox(VbCR&_
" Das Programm hat außer dem 1. Abschnitt:"&UV&_
Txt1&UV&_
" noch die folgenden Abschnitte gefunden :"&VbCR&_
Txt&UV&_
" Bei "" a "" wird obiger erster Abschnitt ange-"&VbCR&_
" zeigt, die weiteren Nummern nur genannt !"&VbCR&_
" Bei "" b "" werden sämtliche Abschnitte ein-"&VbCR&_
" zeln und aufeinander folgend angezeigt !"&VbCR&_
" Oder geben Sie die gewünschte Nr. ein !"&_
VbCR,Titel,"a")
Word=LCase(Word)
If Ask="" then WScript.Quit
End If
If ZahlR>=10 then Ask="a" 'Bei zuviel Fundstellen nur erste ausgeben!
End If '<<<<<<<<<<<<<<<<<<
'Startzeile Start1(i) weiterer - nicht doppelter - Abschnitte suchen:
'********************************************************************
For i=1 to ZahlR
ReDim Preserve Start1(i)
For k=1 to Ende
If Left(Zeile(k),3)=Noch(i-1) then Start1(i)=k
Next
Next
'####################################################
'Ausgabedatei öffnen, gefundene Abschnitte schreiben:
'####################################################
Set File=Fso.OpenTextFile(Datei,2,true)
If (Ask="a" and ZahlR>=1) then
File.WriteLine(" ")
File.WriteLine(" ")
If Zwei="0" then
File.Write("Der Begriff "" "&Wort(0))
File.WriteLine(" "" steht erstmalig in folgendem Abschnitt:")
File.Write("********************************")
File.WriteLine("*********************************")
End If
If Zwei="1" then
File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1))
File.WriteLine(" "" stehen erstmalig in folgendem Abschnitt:")
File.Write("******************************************")
File.WriteLine("***************************************")
End If
End If
If Ask="" then
File.WriteLine(" ")
File.WriteLine(" ")
If Zwei="0" then
File.Write("Der Begriff "" "&Wort(0))
File.WriteLine(" "" steht nur in folgendem Abschnitt:")
File.Write("*****************************")
File.WriteLine("****************************")
End If
If Zwei="1" then
File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1))
File.WriteLine(" "" stehen nur in folgendem Abschnitt:")
File.Write("*************************************")
File.WriteLine("************************************")
End If
End If
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
'Erste Fundstelle ausgeben:
'**************************
If (Ask="a" or Ask="") then
i=Start1(0)
Do until (Zeile(i)="" and Zeile(i+1)="" and _
Zeile(i+2)="" and Zeile(i+3)="")
File.WriteLine(Zeile(i))
i=i+1
Loop
End If
'Alle Fundstellen ausgeben:
'**************************
If Ask="b" then
For k=0 to ZahlR
i=Start1(k)
Do until (Zeile(i)="" and Zeile(i+1)="" and _
Zeile(i+2)="" and Zeile(i+3)="")
File.WriteLine(Zeile(i))
i=i+1
Loop
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
Next
End If
'Gewünschte Fundstelle ausgeben:
'*******************************
If not (Ask="a" or Ask="b" or Ask="") then
i=Start1(Ask-1) 'Nr. beginnen erst mit 2 !
Do until (Zeile(i)="" and Zeile(i+1)="" and _
Zeile(i+2)="" and Zeile(i+3)="")
File.WriteLine(Zeile(i))
i=i+1
Loop
End If
File.WriteLine(" ")
File.WriteLine(" ")
'Bei Anzeige einer Fundstelle die weiteren am Ende angeben:
'**********************************************************
If not Ask="b" then
'Wenn keine weiteren Fundstellen da sind:
'****************************************
If Ort1(0)=Ort1(Zahl1-1) then
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine("Weitere Fundstellen sind nicht vorhanden !")
File.WriteLine("******************************************")
End If
'Weitere Fundstellen, dabei keine doppelt verwenden:
'***************************************************
If not Ort1(0)=Ort1(Zahl1-1) then
File.WriteLine(" ")
File.WriteLine(" ")
If Zwei="0" then
File.Write("Der Begriff "" "&Wort(0))
File.WriteLine(" "" steht in folgenden Abschnitten:")
File.Write("****************************")
File.WriteLine("********************************")
File.WriteLine(" ")
End If
If Zwei="1" then
File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1))
File.WriteLine(" "" stehen in folgenden Abschnitten:")
File.Write("*************************************")
File.WriteLine("************************************")
File.WriteLine(" ")
End If
k=0
Do until k=Zahl1
If Letzte<>Ort1(k) then
File.Write(" "&Ort1(k))
Letzte=Ort1(k)
Reihe=1+Reihe
If Reihe mod 13="0" then File.WriteLine(" ") 'Reihen begrenzen!
End If
If Ort1(k)=Schluss then k=Zahl1-1 'Abbruch am letzten Abschnitt
k=k+1
Loop
End If
End If
'Folgendes muss sein, damit die Datei am Schluss löschbar wird:
'**************************************************************
File.Close
Set File=Nothing
'Bei Erfolg den Abschnitt mit dem Begriff anzeigen:
'**************************************************
Wss.Run "Notepad """&Datei&""" "
WScript.Sleep 2000
'Die Ausgabe-Datei löschen:
'**************************
Fso.DeleteFile Datei
'#############################################################
Sub Doppel
'Die Suche des Begriff2 (Wort(1)) in den neu benannten Zeilen:
'*************************************************************
Hier2=""
Zahl2="0" 'Zahl der Fundstellen
For i=1 to Ende
k=1
Do until k>Len(Zeile(i))-Len(Wort(1))+1
If LCase(Mid(Zeile(i),k,Len(Wort(1))))=Wort(1) then
If Len(Hier2)>0 then Hier2=Hier2&"|"&i
If Hier2="" then Hier2=i
Zahl2=Zahl2+1 'Wie oft "Wort(1)" gefunden ?
End If
k=k+1
Loop
Next
'Oder Abbruch - falls Begriff 2 nicht gefunden wurde:
'****************************************************
If Hier2="" then MsgBox UV&VbCR&"Der Begriff "" "&_
Wort(1)&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Die Aufsplittung der Fundorte in Ort1(0) usw.:
'**********************************************
Ort2=Split(Hier2,"|")
'Die Fundstellen für Wort2 werden markiert:
'******************************************
i=0
Do until i=Zahl2
'Wenn noch nicht markiert:
If not Right(Zeile(Ort2(i)),5)="22222" then
Zeile(Ort2(i))=Zeile(Ort2(i))&" 2222222222"
End If
i=i+1
Loop
'Den Anfang der gefundenen Abschnitte suchen:
'********************************************
ReDim Preserve Start2(Zahl2+1)
a=0
Do until a=Zahl2
Start2(a)=Ort2(a) 'Anfang setzen und rückwärts gehen
k=1
Do until (Zeile(Start2(a))="" and Zeile(Start2(a)-1)="" and _
Zeile(Start2(a)-2)="" and Zeile(Start2(a)-3)="")
Start2(a)=Ort2(a)-k
k=k+1
Loop
Start2(a)=Start2(a)+1
a=a+1
Loop
'Die Nummern dieser Abschnitte ermitteln:
'****************************************
b=0
Do until b=Zahl2
Ort2(b)=Left(Zeile(Start2(b)),3)
b=b+1
Loop
'Gemeinsame Fundstellen beider Begriffe suchen:
'**********************************************
If Zahl1>=Zahl2 then Zahl=Zahl1
If Zahl2>=Zahl1 then Zahl=Zahl2
Hier=""
i=0
Do until i=Zahl1
k=0
Do until k=Zahl2
If Ort1(i)=Ort2(k) then
If Hier="" then Hier=Ort1(i)
If Hier<>"" then Hier=Hier&"|"&Ort1(i)
End If
k=k+1
Loop
i=i+1
Loop
'###########################################################
'Ab hier wird alles so bezeichnet wie bei nur einem Begriff,
'damit die Ausgabe genau so erfolgt wie bei einem Begriff !!
'###########################################################
'Die Aufsplittung der gemeinsamen Fundorte in Ort1(0) usw.:
'**********************************************************
Ort1=Split(Hier,"|")
'Abbruch, falls die beiden Begriffe nicht gemeinsam auftreten:
'*************************************************************
If Hier="" then MsgBox UV&VbCR&"Die Begriffe "" "&Wort(0)&_
" "" und "" "&Wort(1)&" "" "&_
" treten nicht gemeinsam auf ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Die Anzahl der gemeinsamen Fundorte:
'************************************
Zahl1="1"
For i=1 to Len(Hier)
If Mid(Hier,i,1)="|" then Zahl1=1+Zahl1
Next
Fund=Ort1(0) 'Erster gemeinsamer Fundort
'Die Zeilennummer des ersten gemeinsamen Fundortes:
'**************************************************
For i=1 to Ende
If Left(Zeile(i),3)=Fund then Start1(0)=i
Next
End Sub
#########################################################################
>>> suizid.hta <<<
</html>
<head>
<!--
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: suizid.hta
' Autor: CMDR 20080425
' Auf: www.dieseyer.de
'
' Durch die Sub-Prozedur "suicide" wird die HTA, in der sich
' die Prozedur selbst befindet, gelöscht.
'
'************************************************************
-->
<HTA:APPLICATION ID="hta"
SCROLL="no"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
WINDOWSTATE="normal"
NAVIGABLE="no"
APPLICATIONNAME="Selbstlöschende HTA-Datei"
>
<title>"Selbstlöschende HTA-Datei"</title>
</head>
<script language="VBScript">
'*********************************************************
Sub Suicide ' mit Sicherheitskopie
'*********************************************************
Call KopieErstellen
Dim wsh, en
Set wsh = CreateObject( "WScript.Shell" )
en = hta.commandLine
' en = left( en, len( en ) ) '**** auch ohne Parameter folgt ein Leerraum!
wsh.Run "mshta.exe vbscript:(CreateObject(""Scripting.FileSystemObject"").DeleteFile(" & en & "))(window.close)" ', 0, false
window.close
End Sub ' Suicide
'*********************************************************
Sub Suicide1 ' Einzeiler ohne mit Sicherheitskopie
'*********************************************************
CreateObject( "WScript.Shell" ).Run "mshta.exe vbscript:(CreateObject(""Scripting.FileSystemObject"").DeleteFile(" & hta.commandLine & "))(window.close)", 0, false
window.close
End Sub ' Suicide1
'*********************************************************
Sub KopieErstellen
'*********************************************************
Dim QuellDatei, ZielDatei
QuellDatei = hta.commandLine
QuellDatei = Replace( QuellDatei, """", "" )
ZielDatei = QuellDatei & "-"
CreateObject("Scripting.FileSystemObject").CopyFile QuellDatei, ZielDatei
End Sub ' KopieErstellen
</script>
<body bgcolor="lightblue" onClick="suicide()">
<center><h1>Bitte klicken Sie in das Fenster!</h1></center>
</body>
</html>
#########################################################################
>>> syntax-ipadr.vbs <<<
'*** v9.7 *** www.dieseyer.de ******************************
'
' Datei: syntax-ipadr.vbs
' Autor: dieseyer@gmx.de
' (xxx.dexter.xxx@googlemail.com)
' Auf: www.dieseyer.de
'
' Vergl. ad-pcliste.vbs
' Vergl. http://www.regular-expressions.info/examples.html
'
' prüft auf richtige IP-Adr:
' \b(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\b
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, Tst
Txt = "IP-Adr. beginnt mit 192.168." & vbCRLF & vbCRLF
Tst = "192.168.1.-1" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.1.0" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.1.1" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.1.255" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.1.256" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.2.-1" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.3.0" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.255.1" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.256.255" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "192.168.255.256" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "127.0.0.1" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
Tst = "10.11.2.1" : Txt = Txt & Tst & vbTab & " => " & GueltigeIPAdr( Tst ) & vbCRLF
MsgBox Txt, , "46 :: " & Wscript.ScriptName
WScript.Quit
'*** v9.7 *** www.dieseyer.de ******************************
Function GueltigeIPAdr( IP )
'***********************************************************
Dim RegAusdr, IPSyntax
IPSyntax = "\b\b192\.\b168\.1\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\b" ' IP-Adr. beginnt mit 192.168.1
IPSyntax = "\b\b192\.\b168\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\b" ' IP-Adr. beginnt mit 192.168.
Set RegAusdr = New RegExp
RegAusdr.Pattern = IPSyntax
If RegAusdr.Test( IP ) Then
GueltigeIPAdr = TRUE ' : MsgBox GueltigeIPAdr & ": " & IP, , "63 :: " & Titel
Else
GueltigeIPAdr = FALSE ' : MsgBox GueltigeIPAdr & ": " & IP, , "65 :: " & Titel
End If
Set RegAusdr = nothing
End Function ' GueltigeIPAdr( IP )
#########################################################################
>>> syntax-pcname.vbs <<<
'*** v9.7 *** www.dieseyer.de ******************************
'
' Datei: syntax-pcname.vbs
' Autor: xxx.dexter.xxx@googlemail.com
' Auf: www.dieseyer.de
'
' http://www.source-center.de/forum/showthread.php?p=79678
'
' PCName werden vor der Prüfung immer in Großbuchstaben gewandelt!
' ^[0-9]{15}$ PCNamen mit 5..15 Zeichen, nur Ziffern: 123456789012345;
' ^[-_A-Z0-9]{5,15}$ PCNamen mit 5..15 Zeichen, Ziffern und Buchstaben und - und _ : PC-01;
' ^DIESEYER[-_A-Z0-9]{7}$ PCNamen beginnen mit 'DIESEYER' und haben 15 Zeichen: DIESEYER-123456;
' ^DS[A-Z0-9]{13}$ PCNamen beginnen mit 'DS' und haben 15 Zeichen, kein - kein _ : DS1234567890123
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, Tst
Tst = "1sd ddd" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "s2d-ddd" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "ss3_ddd" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "ssd.4dd" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "ssd!d50" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "1" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "12" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "123" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "1234" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "12345678901234" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "123456789012345" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "1234567890123456" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
Tst = "123456789ABCDEFx" : Txt = Txt & Tst & vbTab & " => " & GueltigerPCName( Tst ) & vbCRLF
MsgBox Txt, , "35 :: " & Wscript.ScriptName
WScript.Quit
'*** v9.7 *** www.dieseyer.de ******************************
Function GueltigerPCName( Hostname )
'***********************************************************
' Autor: xxx.dexter.xxx@googlemail.com
' http://www.source-center.de/forum/showthread.php?p=79678
Hostname = UCase( Hostname )
Dim RegAusdr, Tst
Tst = "^[-a-zA-Z0-9!@#\$\%\^&'\(\)\._\{\}~]{1,15}$"
Tst = "^[-_a-zA-Z0-9]{3,15}$" ' 3 bis 15 Zeichen, Buchstaben und Zahle und - und _
Set RegAusdr = New RegExp
RegAusdr.Pattern = Tst
If RegAusdr.Test(Hostname) Then
GueltigerPCName = TRUE ' : MsgBox GueltigerPCName & ": " & PC, , "55 :: " & Titel
Else
GueltigerPCName = FALSE ' : MsgBox GueltigerPCName & ": " & PC, , "57 :: " & Titel
End If
Set RegAusdr = nothing
End Function
#########################################################################
>>> tastaturcode.hta <<<
<head>
<!--
'v5.C*****************************************************
' File: tastaturcode.hta
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
' HTA wird 30s angezeigt und zeigt während dieser Zeit
' den Tastaturcode der Tasten an, die gedrückt wurden.
'*********************************************************
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SHOWINTASKBAR="no"
-->
<title>tastaturcode.hta</title>
<HTA:APPLICATION ID="oHTA"
SCROLL="No"
SHOWINTASKBAR="yes"
NAVIGABLE="no"
APPLICATIONNAME="tastaturcode.hta"
>
<style type="text/css">
<!--
background:#02D020;
background:#1d2160;
-->
<!--
html, body { font-Size:12pt; color:#E0C000; font-family:Verdana; /* font-weight:bold; */
background:#601010;
}
-->
</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 = "tastaturcode.hta"
Const WarteZeit = 30 ' Zeit in Sekunden
Const Tast1 = "49"
Const Tast2 = "50"
Const Tast3 = "51"
Dim Eing1, Eing2, Eing3
Dim TastEing, TimeOutAktiv
Dim Txt, Tst, n
Dim EingListe( 9 )
'****************************************
Sub ZuEnde()
'****************************************
self.close
End Sub ' ZuEnde()
'****************************************
Sub HTASize()
'****************************************
' window.moveto Links, Oben
window.moveto 800-640, 0 ' Position
' window.resizeto Breite, Höhe ' Größe
' window.resizeto 520, screen.height-23
window.resizeto 640, 480
End Sub
'**************************************************************
Sub AktAnzeige()
'**************************************************************
Txt = Txt & " <Span style=""font-size:10pt"">"
Txt = Txt & " Im folgenden wird zu jeder betätigten Taste der"
Txt = Txt & " Tastaturcode angezeigt. Werden 30s keine Eingaben"
Txt = Txt & " getätigt, schliesst sich dieses Programm selbst."
Txt = Txt & " </Span><br><br>"
window.clearTimeout( TimeOutAktiv )
TimeOutAktiv = window.setTimeout( "self.close()", WarteZeit * 1000 )
n = 9
document.all.AnzTaste.innerHTML = Txt
End Sub ' AktAnzeige()
'**************************************************************
Sub document_onKeyDown ' dieseyer.de - tastaturcode.hta v5.C
'**************************************************************
' Dim EingListe( 9 ) ' muss außerhalb der Prozedur / am Anfaang stehen
Dim i, Tst
n = n + 1
If n > UBound( EingListe ) Then n = 0
Tst = window.event.keyCode
MsgBox Tst
If Tst = 27 Then self.close
' Überprüfung ob Tasten in def. Reihenfolge gedrückt wurden
If Tst & "-" = Tast1 & "-" Then Eing1 = Tst
If Tst & "-" = Tast2 & "-" Then Eing2 = Tst
If Tst & "-" = Tast3 & "-" Then Eing3 = Tst
If Tast1 & Tast2 & Tast3 = Eing1 & Eing2 & Eing3 Then self.close
EingListe(n) = Tst
Tst = " <Span style=""font-size:14pt""><fieldset><pre><br> "
For i = LBound( EingListe ) to UBound( EingListe )
Tst = Tst & " " & i & " " & EingListe( i )
If i = n Then Tst = Tst & " <= letzte Eingabe"
if i < UBound( EingListe ) Then Tst = Tst & "<br> "
Next
document.all.AnzTaste.innerHTML = Txt + Tst + "</pre></fieldset></Span>"
window.clearTimeout( TimeOutAktiv )
TimeOutAktiv = window.setTimeout( "self.close()", WarteZeit * 1000 )
End Sub ' document_onKeyDown ' dieseyer.de - tastaturcode.hta v5.C
'**************************************************************
Function BeimLaden() ' ruft einige Routinen auf
'**************************************************************
call HTASize
call AktAnzeige()
End Function ' BeimLaden
'----------------------------------------
</script>
<body onLoad="BeimLaden()" style="background-image:url(winpe.jpg)" >
<form >
<h2 align="center">Tastatureingabe</h2>
<!-- <h2 align="center">- - - Testbetrieb - - -</h2> -->
<table border="0" cellspacing="40px" width="0100%">
<tr >
<td align="Left<" cellspacing="70%" >
<div ID=AnzTaste >
</td>
</tr>
</table>
</form>
</body>
#########################################################################
>>> temp-hilfe.vbs <<<
'
' Datei: temp-hilfe.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: temp-hilfe.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Da im Kopf eines Skripts häufig Erklärungen zur Funktion
' des Skripts hinterlegt sind, kann mit der Sub-Prozedur
' TempHilfeTxt( VBSDatei )
' oder
' TempHilfeHta( VBSDatei )
' eine Hilfe in ein beliebiges Skript integriert werden -
' angezeigt als TXT-Datei (in Notepad) oder als HTA-Datei
' (mit mshta.exe).
'
' Die Prozedur erstellt eine temporäre Datei, in die der Kopf
' des aufrufenden Skripts eingefügt wird. Beginnen und enden
' muss dazu der Text mit:
' '*** (ein Hochkomma, gefolgt von 3 Sternchen)
' oder
' ' *** (ein Hochkomma, ein Leerschritt, 3 Sterne)
'
' Die Tmp-Datei wird im Tmp-Ordner des angemeldeten Users
' angelegt und nach dem Anzeigen gelöscht.
'
' HilfeTxtDatei( ZielDatei )
' Diese Prozedur schreibt den Kopf eines Skripts in eine
' Textdatei - z.B. LiesMich.txt:
' HilfeTxtDatei( "LiesMich.txt" )
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
' WSHShell.Popup "= = = S T A R T = = =", 2, "031 :: " & WScript.ScriptName
Call TempHilfeTxt( "trace32log.vbs" ) ' Sub-Prozedur - Aufruf
Call TempHilfeHta( WScript.ScriptFullName ) ' Sub-Prozedur - Aufruf
Call HilfeTxtDatei( "LiesMich.txt" ) ' Sub-Prozedur - Aufruf; erzeugt aus dem VBS-Kopf eine HilfeDatei
' WSHShell.Popup "= = = E N D E = = =", 2, "039 :: " & WScript.ScriptName
WScript.Quit
'*** v8.3 *** www.dieseyer.de *******************************
Sub TempHilfeTxt( QuellDatei )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst, TxtBereich, ZielDatei
' TmpDatei als Txt-Datei
ZielDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "txt"
' MsgBox vbTab & "ZielDatei: " & vbCRLF & vbCRLF & ZielDatei, , "057 :: " & WScript.ScriptName
TxtBereich = "-Ja"
Set FileIn = fso.OpenTextFile( QuellDatei, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
If TxtBereich = "Ja" AND InStr( Tst, "'***" ) = 1 Then Txt = Txt & Tst & vbCRLF : Exit Do
If TxtBereich = "Ja" AND InStr( Tst, "' ***" ) = 1 Then Txt = Txt & Tst & vbCRLF : Exit Do
If TxtBereich = "-Ja" AND InStr( Tst, "'***" ) = 1 Then TxtBereich = "Ja"
If TxtBereich = "-Ja" AND InStr( Tst, "' ***" ) = 1 Then TxtBereich = "Ja"
If TxtBereich = "Ja" Then Txt = Txt & Tst & vbCRLF
Loop
Set FileOut = fso.OpenTextFile( ZielDatei, 2, true)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run ZielDatei, , True ' wartet nicht auf das Schließen der Anzeige
WSHShell.Run "notepad " & ZielDatei, , True
fso.DeleteFile ZielDatei, True
End Sub ' TempHilfeTxt( QuellDatei )
'*** v8.3 *** www.dieseyer.de *******************************
Sub TempHilfeHta( Datei )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst, TxtBereich
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "096 :: " & WScript.ScriptName
Txt = ""
Txt = Txt & vbTab & "099 :: """ & Datei & """, letzte " & vbCRLF
Txt = Txt & vbTab & "100 :: " & "Änderung vom " & fso.GetFile( Datei ).DateLastModified & ", enthält" & vbCRLF
Txt = Txt & vbTab & "101 :: " & "folgende Infos:" & vbCRLF & vbCRLF
TxtBereich = "-Ja"
Set FileIn = fso.OpenTextFile( Datei, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
If TxtBereich = "Ja" AND InStr( Tst, "'***" ) = 1 Then Txt = Txt & Mid( Tst, 2 ) & vbCRLF : Exit Do
If TxtBereich = "Ja" AND InStr( Tst, "' ***" ) = 1 Then Txt = Txt & Mid( Tst, 2 ) & vbCRLF : Exit Do
If TxtBereich = "-Ja" AND InStr( Tst, "'***" ) = 1 Then TxtBereich = "Ja"
If TxtBereich = "-Ja" AND InStr( Tst, "' ***" ) = 1 Then TxtBereich = "Ja"
If TxtBereich = "Ja" Then Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, true)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta( Datei )
'*** v8.4 *** www.dieseyer.de *******************************
Sub HilfeTxtDatei( ZielDatei )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst, TxtBereich
' Temporäre Datei als Ziel-Txt-Datei
' ZielDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "txt"
' MsgBox vbTab & "ZielDatei: " & vbCRLF & vbCRLF & ZielDatei, , "820 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "823 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "824 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "825 :: " & "folgende Infos:" & vbCRLF & vbCRLF
TxtBereich = "-Ja"
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
If TxtBereich = "Ja" AND InStr( Tst, "'***" ) = 1 Then Txt = Txt & Mid( Tst, 2 ) & vbCRLF : Exit Do
If TxtBereich = "Ja" AND InStr( Tst, "' ***" ) = 1 Then Txt = Txt & Mid( Tst, 2 ) & vbCRLF : Exit Do
If TxtBereich = "-Ja" AND InStr( Tst, "'***" ) = 1 Then TxtBereich = "Ja"
If TxtBereich = "-Ja" AND InStr( Tst, "' ***" ) = 1 Then TxtBereich = "Ja"
If TxtBereich = "Ja" Then Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
Loop
Set FileOut = fso.OpenTextFile( ZielDatei, 2, True)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
WSHShell.Run ZielDatei, , True
' fso.DeleteFile ZielDatei, True
End Sub ' HilfeTxtDatei( ZielDatei )
#########################################################################
>>> terminemelden.vbs <<<
'*** v10.1 *** www.dieseyer.de *****************************
'
' Datei: terminemelden.vbs
' Autor: W. Schmelz
' Auf: www.dieseyer.de
'
'***********************************************************
'**************************************************************
' *
' Datei: " TermineMelden.vbs " *
' *
' Die neue Version verwendet keine komplizierten Objekte und *
' läuft darum in allen Win-Versionen ! Beim allerersten Start *
' wird die Datei nach "C:\Programme\Schmelz.W\TermineMelden" *
' kopiert, ein Link in den Desktop und in Autostart gesetzt! *
' Der "Link" im Autostart wird aber nur aktiv, wenn Meldungen *
' noch gespeichert sind und auszuführen oder zu löschen sind. *
' In "Programme\Schmelz.W" werden Protokolle der Aufträge ge- *
' speichert, die nach der Meldung gelöscht werden. Falls aber *
' " Leichen " durch Abschaltung oder Absturz verbleiben, kön- *
' nen diese auf Wunsch aus dem Programm her gelöscht werden ! *
' Wenn schon Meldungen laufen, so werden sie anfangs gezeigt! *
' Beim 1. Mal startet die "Suchschleife". Sie bleibt, solange *
' Meldungen da sind, in der Lauer, ob Datum und Zeit für eine *
' Meldung eingetreten sind. Die Melde- Aufträge werden danach *
' gelöscht ! Wegen der Bauweise kann man Datum, Zeit und Mel- *
' dung noch ändern - oder sie löschen! - Keinerlei Gewähr für *
' das korrekte Laufen des Programmes, d.h. verpasste Termine! *
' *
'**************************************************************
' CopyRight: W. Schmelz, 28.12.2009
'Objekte u.a. für das Programm bereit stellen:
'*********************************************
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
WinDir=Wss.ExpandEnvironmentStrings("%WinDir%")
Dat0="C:\Programme\Schmelz.W\TermineMelden\"
Dat1="C:\Dokumente und Einstellungen\All Users"
DatX=Dat0&"TermineMelden.vbs"
Datei0=Dat0&"Termine\Meldung."&"h"&"t"&"a"
Datei01=Dat0&"Termine\Info."&"h"&"t"&"a"
DatSuch=Dat0&"Termine\SuchSchleife.txt"
AktVerz=Replace(WScript.ScriptFullName,WScript.ScriptName,"")
Titel=" Hier kommt der Wecker ! ! !"
UV=VbCR&VbCR
Dim Meldng, Zeile(), Zeil(), Datei0, DateiX, Meldg(), Schalt
Dim Multi, Numr, Melden, Korr, Produkt, Datei01, Zahl, Such
Dim Dat0, Dat1, DatX, AktVerz, XYZ, Lauf, Menge
'Die Ordner für das Programm anlegen:
'************************************
If not Fso.FolderExists("C:\Programme\Schmelz.W") then _
Fso.CreateFolder "C:\Programme\Schmelz.W", true
'" true " soll evtl. Schreibschutz aushebeln!
If not Fso.FolderExists("C:\Programme\Schmelz.W\TermineMelden") _
then Fso.CreateFolder "C:\Programme\Schmelz.W\TermineMelden"
If not Fso.FolderExists("C:\Programme\Schmelz.W\TermineMelden\Termine") _
then Fso.CreateFolder "C:\Programme\Schmelz.W\TermineMelden\Termine"
If not Fso.FolderExists ("C:\Programme\Schmelz.W\TermineMelden") then
MsgBox UV&UV&"Die Programmordner konnten nicht angelegt werden !"&_
" "&UV&UV,VbCritical,Titel:WScript.Quit
End If
'*************************************************************
' *
' Bei dem allerersten Start dieses "TermineMelden"-Programms *
' Datei nach C:\Programme\Schmelz.W\TermineMelden kopieren, *
' in den Autostart wird der Start dieses Programmes verlegt *
' und einen Link des Programmes in den " Desktop " gesetzt : *
' *
'*************************************************************
If not Fso.FileExists(DatX) then
'Nachfrage, ob Programm zu installieren ist:
'*******************************************
Txt=UV&UV&"Soll das Termin-Melde-Programm installiert werden ? "&_
UV&"Es kommt nach ""C:\Programme\Schmelz.W"", ein Link "&_
UV&"dazu auf den ""Desktop"" und einer in den ""Autostart"","&_
UV&"der bei noch bestehenden Meldungen tätig wird !"&UV&UV
Ask = MsgBox(Txt,VbOkCancel+VbDefaultButton1+VbQuestion,Titel )
Txt=UV&VbCR&VbTab&"Na gut , . . . dann halt nicht ! "&UV
If Ask=VbCancel then MsgBox Txt&VbCR,,Titel:WScript.Quit
'Autostart für Win98/ME und XP festlegen:
'****************************************
If not Fso.FolderExists(Dat1) then _
Autostart=WinDir&"\Startmenü\Programme\Autostart"
If Fso.FolderExists(Dat1) then _
Autostart=Wss.SpecialFolders("AllUsersStartup")
Start=Autostart&"\Termine.vbs"
Fso.CopyFile(WScript.ScriptFullName),(DatX)
WScript.Sleep 500
'Falls Datei nicht installiert werden kann:
'******************************************
If not Fso.FileExists(DatX) then WScript.Quit
'Datei für den "Autostart" schreiben:
'************************************
Set F=Fso.CreateTextFile(Start,true)
F.WriteLine(" ")
F.WriteLine(" Set Fso=WScript.CreateObject(""Scripting.FileSystemObject"") ")
F.WriteLine(" Set Wss=CreateObject(""Wscript.Shell"") ")
F.WriteLine(" ")
F.WriteLine(" WScript.Sleep 150000 ")
F.WriteLine(" ")
F.WriteLine(" Dat0=""C:\Programme\Schmelz.W\TermineMelden\"" ")
F.WriteLine(" DatX=Dat0&""TermineMelden.""&""v""&""b""&""s"" ")
F.WriteLine(" DatSuch=Dat0&""Termine\SuchSchleife.txt"" ")
F.WriteLine(" If Fso.FileExists(DatSuch) then Fso.DeleteFile(DatSuch) ")
F.WriteLine(" ")
F.WriteLine(" Set Ort=Fso.GetFolder(Dat0&""Termine"").Files ")
F.WriteLine(" For each File in Ort ")
F.WriteLine(" If Left(Fso.GetFileName(File),4)=""Weck"" then ")
F.WriteLine(" Kontrl=Dat0&""Termine\Start.txt"" ")
F.WriteLine(" Fso.CopyFile(File),(Kontrl) ")
F.WriteLine(" Wss.Run DatX ")
F.WriteLine(" WScript.Sleep 500 ")
F.WriteLine(" WScript.Quit ")
F.WriteLine(" End If ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.Close
Set F=Nothing
'Link in den Desktop setzen:
'***************************
Path=Wss.SpecialFolders("Desktop")
Set Lnk=Wss.CreateShortcut(Path&"\TermineMelden.lnk")
Lnk.TargetPath=Wss.ExpandEnvironmentStrings(DatX)
Lnk.Save
End If
'Wenn von anderer Stelle gestartet, übergehen in richtigen
'Ordner in Programme. Es wird von dort weiter gearbeitet !
'*********************************************************
If Fso.FileExists(DatX) then
If not AktVerz="C:\Programme\Schmelz.W\TermineMelden\" then
Wss.Run DatX
WScript.Sleep 500
WScript.Quit '"Falsche" Startdatei schließen!
End If
End If
'Wenn keine Meldungen, Suchdatei schließen:
'******************************************
Menge="0" 'Kontrolle, ob Meldungen laufen
For i=1 to 50
If Fso.FileExists(Dat0&"Termine\Wecker"&i&".txt") then Menge=1+Menge
Next
If Menge="0" then
If Fso. FileExists(DatSuch) then Fso.DeleteFile(DatSuch)
End If
'*****************************************************************
' *
' Falls die Datei "Meldung.h-t-a" noch nicht existiert: *
If not Fso.FileExists(Datei0) then '*
' ************************************ *
' Beim Start die folgenden H-t-a-Dateien erst schreiben und dann *
' laufen lassen. Die 1. zeigt Meldungen in "Programme\Schmelz.W" *
' Dieser Abschnitt endet bei etwa 80 % dieser Datei! ("###..##") *
' *
'*****************************************************************
'Welche Meldungen liegen schon vor?
'**********************************
Zahl="0"
i=1
Do until i>50
ReDim Preserve Meldg(i)
If Fso.FileExists(Dat0&"Termine\Wecker"&i&".txt") then
Zahl=1+Zahl 'Laufende Meldungen zählen
Set Data=Fso.OpenTextFile(Dat0&"Termine"&"\Wecker"&i&".txt")
k=1
Do until Data.AtEndOfStream
ReDim Preserve Zeile(k)
Zeile(k)=Data.ReadLine
k=k+1
Loop
Data.Close
Set Data=Nothing
'Meldungen lesen, Nr. für´s Sortieren zunächst nach hinten!
'**********************************************************
If Len(i)="1" then Ende="0"&i 'i ist Nr von Wecker*.txt
Txt=Right(Zeile(4),Len(Zeile(4)) - 28)
Meldg(Zahl)=Right(Zeile(3),6)&_
" um "&Mid(Zeile(4),4,9)&":"&Txt&" "&Ende
' Problem bei 1 Meldung, s. Sortieren
If Zahl="1" then Melden=Meldg(1)
End If
i=i+1
Loop
If Zahl>"1" then
'Meldg(i) alphabetisch sortieren:
'********************************
For a=1 to Zahl
For b=a+1 to Zahl
If Meldg(a)>Meldg(b) then
klm=Meldg(a)
Meldg(a)=Meldg(b)
Meldg(b)=klm
End if
Next
Next
'Nrn. nach vorne stellen, Liste erstellen:
'*****************************************
i=1
Do until i>Zahl
Meldg(i)=Right(Meldg(i),2)&": "&_
Left(Meldg(i),Len(Meldg(i))-2)
Text=Text&VbCR&Meldg(i)
i=i+1
Loop
End If
'Als Sonderfälle nötig : eine oder keine Meldung:
'************************************************
If Zahl="1" then
Melden=Right(Melden,2)&": "&Left(Melden,Len(Melden)-2)
Text=VbCR&Melden
End If
If Zahl="0" then Text=UV&_
" Keine Meldungen ! ! !"&VbCR
'Heutiges Datum, Wochentag ermitteln:
'************************************
Tag=Weekday(Date) 'Wochentag suchen!
Select Case Tag
Case "1" Tg="Sonntag"
Case "2" Tg="Montag"
Case "3" Tg="Dienstag"
Case "4" Tg="Mittwoch"
Case "5" Tg="Donnerstag"
Case "6" Tg="Freitag"
Case "7" Tg="Samstag"
End Select
'Immer gleiche Länge schaffen:
Lang=11-Len(Tg)
For i=1 to Lang
Tg=" "&Tg
Next
'Prüfen, ob Suchschleife läuft:
'******************************
If Fso.FileExists(DatSuch) then
Schalt="0"
else
Schalt="1"
End If
'************************************************************
' *
' 1. H-t-a-Datei für Informationen über Zeit und Meldungen: *
' *
'************************************************************
Datei01=Dat0&"Termine\Info."&"h"&"t"&"a"
Set F=Fso.CreateTextFile(Datei01,true)
F.WriteLine(" ")
F.WriteLine(" <Html> ")
F.WriteLine(" <Head> ")
F.WriteLine(" ")
F.Write(" <Hta:Application Id=""OHTA"" ")
F.WriteLine(" Border=""Yes"" InnerBorder=""Yes"" Scroll=""No""> ")
F.Write(" <Title> . . . . . . . . . . . . ")
F.Write(" Termin - Melde - Programm . . . </Title> ")
F.WriteLine(" <Style Type=""Text/Css""> ")
F.WriteLine(" ")
F.Write(" TD {Font-size:13Pt;color:Black; ")
F.WriteLine(" Font-style:bold;font-family:Verdana} ")
F.Write(" Input{Font-size:13pt;color:Black; ")
F.WriteLine(" Font-style:bold;font-family:Verdana} ")
F.Write(" H2 {Font-size:16pt;color:DarkRed; ")
F.WriteLine(" Font-style:bold;font-family:Verdana} ")
F.WriteLine(" ")
F.WriteLine(" </Style> ")
F.WriteLine(" </Head> ")
F.WriteLine(" ")
F.WriteLine(" <Script Language=""VBScript""> ")
F.WriteLine(" Set Wss=CreateObject(""Wscript.Shell"") ")
F.WriteLine(" Set Fso=CreateObject(""Scripting.FileSystemObject"") ")
F.WriteLine(" ")
F.WriteLine(" Dat0=""C:\Programme\Schmelz.W\TermineMelden\"" ")
F.WriteLine(" UV=VbCR&VbCR ")
F.WriteLine(" Dim Dat0, UV ")
F.WriteLine(" ")
' Window.ResizeTo: Fenster hoch, breit
F.WriteLine(" Window.ResizeTo 660,500 ")
' Window.MoveTo: Fenster von oben links nach rechts unten schieben!
F.WriteLine(" Window.MoveTo 250,100 ")
If Zahl > 3 then 'Falls mehr Meldungen, Fenster weiter vergrößern!
F.WriteLine(" Window.ResizeTo 660,660 ")
F.WriteLine(" Window.MoveTo 250,50 ")
End If
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" Sub Schluss ")
F.WriteLine(" Datei0=Dat0&""Termine\Meldung.""&""h""&""t""&""a"" ")
F.WriteLine(" Datei01=Dat0&""Termine\Info.""&""h""&""t""&""a"" ")
F.WriteLine(" If Fso.FileExists(Datei0) then Fso.DeleteFile(Datei0) ")
F.WriteLine(" If Fso.FileExists(Datei01) then Fso.DeleteFile(Datei01) ")
F.WriteLine(" Self.Close ")
F.WriteLine(" WScript.Quit ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" Sub Weiter ")
F.WriteLine(" Datei01=Dat0&""Termine\Info.""&""h""&""t""&""a"" ")
F.WriteLine(" If Fso.FileExists(Datei01) then Fso.DeleteFile(Datei01) ")
F.WriteLine(" Wss.Run Dat0&""Termine\Meldung.""&""h""&""t""&""a"" ")
F.WriteLine(" Self.Close ")
F.WriteLine(" WScript.Quit ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" </Script> ")
F.WriteLine(" </Head> ")
F.WriteLine(" ")
F.WriteLine(" <Body OnLoad="""" bgcolor=""#f0e68c""> ")
F.WriteLine(" <Form> ")
F.WriteLine(" ")
F.WriteLine(" <BR> ")
F.WriteLine(" <H2 Align=""Center""> Es liegen folgende Meldungen vor : ")
F.WriteLine(" <BR> ")
'Über proz. Breite und Höhe das Innenfenster an Außenfenster anpassen:
F.Write(" <Table Border=""6"" Cellspacing=""10px"" ")
F.WriteLine(" Width=""90%"" Height=""85%""> ")
F.WriteLine(" <Tr> ")
F.WriteLine(" <Td bgcolor=#90ee90> ")
F.WriteLine(" ")
F.WriteLine(" <BR> ")
XYZ = " "
DatZeit = "Heute ist "&Tg&", der "&Date&", um "&Left(Time,5)&" Uhr ! "
F.WriteLine( XYZ&DatZeit )
F.WriteLine(" <BR><BR> ")
If Zahl>1 then
i=1
Do until i>Zahl
F.WriteLine(XYZ&Meldg(i)&"<BR> ")
i=i+1
Loop
else
F.WriteLine(XYZ&Melden&"<BR> ")
End If
If Zahl>=1 then
If Schalt="1" then 'Die Suchschleife ist zu starten !
F.Write(" <BR> ")
F.WriteLine(" Noch läuft keine ""Suchschleife"", bitte sie gleich starten:")
F.Write(" <BR> ")
F.WriteLine(" Neue Termine speichern- oder nur Suchschleife starten! ")
End If
End If
If Zahl="0" then
F.WriteLine(XYZ&XYZ&XYZ&XYZ&XYZ&" Es liegen keine Meldungen vor! ")
F.WriteLine(" <BR><BR><BR><BR> ")
End If
F.WriteLine(" ")
F.WriteLine(" <Center> ")
F.WriteLine(" <BR> <BR> ")
F.Write(" <Input Type=""Button"" Name=""Start"" ")
F.WriteLine(" Value="" Weiter !"" OnClick=""Weiter""> ")
F.WriteLine(" ")
F.Write(" <Input Type=""Button"" Name=""Ende"" ")
F.WriteLine(" Value=""Abbruch"" OnClick=""Schluss""> ")
F.WriteLine(" <BR><BR> ")
F.WriteLine(" </Center> ")
F.WriteLine(" ")
F.WriteLine(" </Td> ")
F.WriteLine(" </Tr> ")
F.WriteLine(" </Table> ")
F.WriteLine(" </Form> ")
F.WriteLine(" </Body> ")
F.WriteLine(" </Html> ")
F.WriteLine(" ")
F.Close
Set F=Nothing
'********************************************************************
' *
' Entscheidende 2. H-t-a-Datei in "Programme\Schmelz.W" schreiben , *
' in der geplante Meldungen eingetragen und Befehle erteilt werden: *
' *
'********************************************************************
Datei0=Dat0&"Termine\Meldung."&"h"&"t"&"a"
If Fso.FileExists(Datei0) then Fso.DeleteFile(Datei0)
Set F=Fso.CreateTextFile(Datei0,true)
F.WriteLine(" ")
F.WriteLine(" <Html> ")
F.WriteLine(" <Head> ")
F.WriteLine(" ")
F.Write(" <Hta:Application Id=""OHTA"" ")
F.WriteLine(" Border=""Yes"" InnerBorder=""Yes"" Scroll=""No""> ")
F.Write(" <Title> . . . . . . . . . . . . ")
F.Write(" Termin - Melde - Programm . . . </Title> ")
F.WriteLine(" <Style Type=""Text/Css""> ")
F.WriteLine(" ")
F.Write(" TD {Font-size:13Pt;color:Black; ")
F.WriteLine(" Font-style:bold;font-family:Verdana} ")
F.Write(" Input{Font-size:13pt;color:Black; ")
F.WriteLine(" Font-style:bold;font-family:Verdana} ")
F.Write(" H2 {Font-size:16pt;color:DarkRed; ")
F.WriteLine(" Font-style:bold;font-family:Verdana} ")
F.WriteLine(" ")
F.WriteLine(" </Style> ")
F.WriteLine(" </Head> ")
F.WriteLine(" ")
F.WriteLine(" <Script Language=""VBScript""> ")
F.WriteLine(" Set Wss=CreateObject(""Wscript.Shell"") ")
F.WriteLine(" Set Fso=CreateObject(""Scripting.FileSystemObject"") ")
F.WriteLine(" Dat0=""C:\Programme\Schmelz.W\TermineMelden\"" ")
F.WriteLine(" DatX=Dat0&""TermineMelden.""&""v""&""b""&""s"" ")
F.WriteLine(" UV=VbCR&VbCR ")
F.WriteLine(" XYZ="" "" ")
F.WriteLine(" Dim XYZ, UV, WinDir, Dat0, DatX, Lauf, Menge ")
F.WriteLine(" ")
'Window.ResizeTo : Fenster hoch, breit
F.WriteLine(" Window.ResizeTo 660,625 ")
'Window.MoveTo : Fenster von oben links nach rechts unten schieben!
F.WriteLine(" Window.MoveTo 250,75 ")
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" Sub Schluss ") 'Meldung.h-t-a läuft weiter !
F.WriteLine(" Datei01=Dat0&""Termine\Info.""&""h""&""t""&""a"" ")
F.WriteLine(" If Fso.FileExists(Datei01) then Fso.DeleteFile(Datei01) ")
F.WriteLine(" If Fso.FileExists(Dat0&""Termine/Start.txt"") then _ ")
F.WriteLine(" Fso.DeleteFile(Dat0&""Termine/Start.txt"") ")
F.WriteLine(" Self.Close ")
F.WriteLine(" WScript.Quit ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" Sub Schluss2 ") 'hier wird alles unterbrochen !
F.WriteLine(" Datei0=Dat0&""Termine\Meldung.""&""h""&""t""&""a"" ")
F.WriteLine(" Datei01=Dat0&""Termine\Info.""&""h""&""t""&""a"" ")
F.WriteLine(" If Fso.FileExists(Datei0) then Fso.DeleteFile(Datei0) ")
F.WriteLine(" If Fso.FileExists(Datei01) then Fso.DeleteFile(Datei01) ")
F.WriteLine(" If Fso.FileExists(Dat0&""Termine/Start.txt"") then _ ")
F.WriteLine(" Fso.DeleteFile(Dat0&""Termine/Start.txt"") ")
F.WriteLine(" Self.Close ")
F.WriteLine(" WScript.Quit ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" Sub Weiter ")
F.WriteLine(" ")
F.WriteLine(" Titel="" Uhrzeit und Meldung eingeben !"" ")
F.WriteLine(" UV=VbCR&VbCR ")
F.WriteLine(" ")
F.WriteLine(" Datei01=Dat0&""Termine\Info.""&""h""&""t""&""a"" ")
F.WriteLine(" If Fso.FileExists(Datei01) then Fso.DeleteFile(Datei01) ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Falls nur die Suchschleife gestartet wird: ")
F.WriteLine(" If Document.All.Opt0.Checked then ")
If Schalt="0" then 'Wenn Suchschleife schon läuft!
F.Write(" MsgBox UV&VbCR&"" Die Suchschleife läuft bereits schon !"" ")
F.WriteLine(" &"" ""&UV&VbCR, VbCritical ")
F.WriteLine(" Exit Sub ")
End If
If Schalt="1" then 'Wenn Suchschleife eingeschaltet werden soll!
'Doppelten Lauf verhindern:
F.WriteLine(" If Fso.FileExists (Dat0&""Termine\Suchschleife.txt"") then ")
F.Write(" MsgBox UV&VbCR&"" Die Suchschleife läuft bereits schon !"" ")
F.WriteLine(" &"" ""&UV&VbCR, VbCritical ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If")
'Unnützen Lauf verhindern:
F.WriteLine(" Menge=""0"" 'Kontrolle, ob Meldungen laufen ")
F.WriteLine(" For i=1 to 50 ")
F.WriteLine(" If Fso.FileExists(Dat0&""Termine\Wecker""&i&"".txt"") then Menge=1+Menge ")
F.WriteLine(" Next ")
F.WriteLine(" If Menge=""0"" then ")
F.Write(" MsgBox UV&VbCR&"" Die Suchschleife ist noch unnötig !"" ")
F.WriteLine(" &"" ""&UV&VbCR,VbCritical ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
'Suchschleife jetzt starten:
F.Write("MsgBox UV&VbCR&VbTab&""Die Suchschleife wird jetzt gestartet !"" ")
F.WriteLine(" &"" ""&UV&VbCR ")
F.WriteLine(" If Fso.FileExists(Dat0&""Termine\SuchSchleife.txt"") then _")
F.WriteLine(" Fso.DeleteFile(Dat0&""Termine\SuchSchleife.txt"") ")
F.WriteLine(" Wss.Run DatX ")
F.WriteLine(" Lauf=""1"" ")
F.WriteLine(" Exit Sub ")
End If
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Falls veraltete Meldungen zu löschen: ")
F.WriteLine(" If Document.All.Opt3.Checked then ")
F.WriteLine(" ")
F.WriteLine(" Nmr=""0"" 'Zahl der veralteten Meldungen ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>50 ")
F.WriteLine(" ")
F.WriteLine("If Fso.FileExists(Dat0&""Termine""&""\Wecker""&i&"".txt"") then ")
F.WriteLine(" ")
F.Write(" Set Data=Fso.OpenTextFile(Dat0&")
F.WriteLine(" ""Termine""&""\Wecker""&i&"".txt"") ")
F.WriteLine(" k=1 ")
F.WriteLine(" Do until Data.AtEndOfStream ")
F.WriteLine(" ReDim Preserve Zeile(k) ")
F.WriteLine(" Zeile(k)=Data.ReadLine ")
F.WriteLine(" k=k+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" Data.Close ")
F.WriteLine(" ")
F.WriteLine(" 'Aus vergangenen Tagen, Zeiten verflossen? ")
F.WriteLine(" If (Right(Zeile(3),6)<Left(Now,6) or _ ")
F.WriteLine(" (Right(Zeile(3),6)=Left(Now,6) and _ ")
F.WriteLine(" Mid(Now,12,5)>=Mid(Zeile(4),4,5))) then ")
F.WriteLine(" Fso.DeleteFile(Dat0&""Termine""&""\Wecker""&i&"".txt"") ")
F.WriteLine(" Nmr=1+Nmr ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" MsgBox UV&UV&_ ")
F.WriteLine(" ""Es wurden ""&Nmr&"" veraltete Meldungen gelöscht !""&_ ")
F.WriteLine(" "" ""&UV&UV,VbInformation, _ ")
F.WriteLine(" "" Veraltete Meldungen wurden gelöscht !!!"" ")
F.WriteLine(" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Falls alle Meldungen zu löschen: ")
F.WriteLine(" If Document.All.Opt2.Checked then ")
F.WriteLine(" ")
F.WriteLine(" Nmr=""0"" 'Zahl vorliegender Meldungen ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>50 ")
F.WriteLine(" ")
F.WriteLine("If Fso.FileExists(Dat0&""Termine""&""\Wecker""&i&"".txt"") then")
F.WriteLine(" ")
F.WriteLine(" Fso.DeleteFile(Dat0&""Termine""&""\Wecker""&i&"".txt"") ")
F.WriteLine(" Nmr=1+Nmr ")
F.WriteLine(" ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" MsgBox UV&UV&_ ")
F.WriteLine("""Es wurden ""&Nmr&"" vorliegende Meldungen gelöscht !""&_ ")
F.WriteLine(" "" ""&UV&UV,VbInformation, _ ")
F.WriteLine(" "" Die vorliegenden Meldungen sind gelöscht !!!"" ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Falls Meldungen zu ändern: ")
F.WriteLine(" If Document.All.Opt4.Checked then ")
F.Write(" Wss.Run ""Explorer.exe""&"" ""&""/n,/e,C:\Programme\")
F.WriteLine("Schmelz.W\TermineMelden\Termine"" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Sechs freie Nummern suchen! ")
F.WriteLine(" For i=1 to 6 ")
F.WriteLine(" ReDim Preserve Nr(i) ")
F.WriteLine(" Nr(i)=""0"" ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" k=1 ")
F.WriteLine(" For i=1 to 6 ")
F.WriteLine(" Neue=""0"" ")
F.WriteLine(" Nr(i)=k ")
F.WriteLine(" Do until Neue=""1"" ")
F.Write(" If not Fso.FileExists(""C:\Programme\Schmelz.W\TermineMelden\")
F.WriteLine("Termine\Wecker""&k&"".txt"") then ")
F.WriteLine(" Nr(i)=k ")
F.WriteLine(" Neue=""1"" ")
F.WriteLine(" End If ")
F.WriteLine(" k=k+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Einträge lesen, überprüfen: ")
F.WriteLine(" For i=1 to 6 ")
F.WriteLine(" ReDim Preserve Tag(i) ")
F.WriteLine(" ReDim Preserve Zeit(i) ")
F.WriteLine(" ReDim Preserve Mdg(i) ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" Tag(1)=Document.All.Tg1.value ")
F.WriteLine(" Zeit(1)=Document.All.Zt1.value ")
F.WriteLine(" Mdg(1)=Document.All.Md1.value ")
F.WriteLine(" Tag(2)=Document.All.Tg2.value ")
F.WriteLine(" Zeit(2)=Document.All.Zt2.value ")
F.WriteLine(" Mdg(2)=Document.All.Md2.value ")
F.WriteLine(" Tag(3)=Document.All.Tg3.value ")
F.WriteLine(" Zeit(3)=Document.All.Zt3.value ")
F.WriteLine(" Mdg(3)=Document.All.Md3.value ")
F.WriteLine(" Tag(4)=Document.All.Tg4.value ")
F.WriteLine(" Zeit(4)=Document.All.Zt4.value ")
F.WriteLine(" Mdg(4)=Document.All.Md4.value ")
F.WriteLine(" Tag(5)=Document.All.Tg5.value ")
F.WriteLine(" Zeit(5)=Document.All.Zt5.value ")
F.WriteLine(" Mdg(5)=Document.All.Md5.value ")
F.WriteLine(" Tag(6)=Document.All.Tg6.value ")
F.WriteLine(" Zeit(6)=Document.All.Zt6.value ")
F.WriteLine(" Mdg(6)=Document.All.Md6.value ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine("'Das Datum sinnvoll? ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>6 ")
F.WriteLine(" If Tag(i)<>"""" then ")
F.WriteLine(" If InStr(Tag(i),""."")=""2"" then Tag(i)=""0""&Tag(i) ")
F.Write(" If Len(Tag(i))=""5"" and not Right(Tag(i),1)=""."" ")
F.WriteLine(" then Tag(i)=Tag(i)&""."" ")
F.Write(" If Len(Tag(i))=""5"" and Right(Tag(i),1)=""."" ")
F.WriteLine(" then Tag(i)=Left(Tag(i),3)&""0""&Right(Tag(i),2) ")
F.WriteLine(" ")
F.WriteLine(" Tag(i)=Left(Tag(i),5) ")
F.WriteLine(" ")
F.Write(" If (Left(Now,2)>Left(Tag(i),2) and not ")
F.Write(" Mid(Now,4,2)<Right(Tag(i),2)) or (Left(Now,2)>Left(Tag(i),2) ")
F.WriteLine(" and Right(Tag(i),2)=Mid(Now,4,2)) then ")
F.WriteLine(" MsgBox UV&"" Das Datum ""&i&"" liegt zurück ! ! ! ""&UV ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" If(InStr(Tag(i),""."")>""3"" or InStrRev(Tag(i),""."")>""3"") then")
F.WriteLine(" MsgBox UV&"" Das Datum ""&i&"" ist sinnlos ! ! ! ""&UV ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" Tag(i)=Tag(i)&""."" ")
F.WriteLine(" ")
F.WriteLine(" If (Len(Tag(i))>""6"" _ ")
F.WriteLine(" or Left(Tag(i),2)>""31"" or Mid(Tag(i),4,2)>""12"") then ")
F.WriteLine(" MsgBox UV&"" Das Datum ""&i&"" ist sinnlos ! ! ! ""&UV ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Die Uhrzeiten sinnvoll? ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>6 ")
F.WriteLine(" If Zeit(i)<>"""" then ")
F.WriteLine(" If InStr(Zeit(i),"":"")=""2"" then Zeit(i)=""0""&Zeit(i) ")
F.WriteLine(" ")
F.WriteLine(" If (Mid(Now,12,5)>Zeit(i) and Tag(i)=Left(Now,6)) then ")
F.WriteLine(" MsgBox UV&"" Die Uhrzeit ""&i&"" liegt zurück ! ! ! ""&UV ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" If (Len(Zeit(i))>""5"" _")
F.WriteLine(" or Left(Zeit(i),2)>""23"" or Right(Zeit(i),2)>""59"") then ")
F.WriteLine(" MsgBox UV&"" Die Uhrzeit ""&i&"" ist sinnlos ! ! ! ""&UV ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Das Datum eingetragen? ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>6 ")
F.WriteLine(" If (Zeit(i)<>"""" and Mdg(i)<>"""") then ")
F.WriteLine(" If Tag(i)="""" then MsgBox UV&_ ")
F.WriteLine(" "" Das Datum ""&i&"" wurde nicht eingetragen ! ""&_ ")
F.WriteLine(" UV,,Titel:Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Die Zeiten eingetragen? ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>6 ")
F.WriteLine(" If (Tag(i)<>"""" and Mdg(i)<>"""") then ")
F.WriteLine(" If Zeit(i)="""" then MsgBox UV&_ ")
F.WriteLine(" "" Die Uhrzeit ""&i&"" wurde nicht eingetragen ! ""&_ ")
F.WriteLine(" UV,,Titel:Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Die Meldungen eingetragen? ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>6 ")
F.WriteLine(" If (Tag(i)<>"""" and Zeit(i)<>"""") then ")
F.WriteLine(" If Mdg(i)="""" then MsgBox UV&_ ")
F.WriteLine(" "" Die Meldung ""&i&"" wurde nicht eingetragen ! ""&_ ")
F.WriteLine(" UV,,Titel:Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Überhaupt etwas eingetragen? ")
F.WriteLine(" Leer=""0"" " )
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>6 ")
F.WriteLine(" If ((Tag(i)<>"""" and Zeit(i)="""" and Mdg(i)="""") or _ ")
F.WriteLine(" (Tag(i)="""" and Zeit(i)="""" and Mdg(i)="""")) then _ ")
F.WriteLine(" Leer=1+Leer ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" If Leer=""6"" then ")
F.WriteLine(" MsgBox UV&_ ")
F.WriteLine(" "" Es wurde keine Meldung eingetragen ! ""&_ ")
F.WriteLine(" UV,,Titel:Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" ")
F.WriteLine(" 'Protokoll-Dateien in Programme\Schmelz.W setzen: ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>6 ")
F.WriteLine(" If Zeit(i)<>"""" then ")
F.WriteLine(" Datei1=Dat0&""Termine""&""\Wecker""&Nr(i)&"".txt"" ")
F.WriteLine(" Set Data=Fso.CreateTextFile(Datei1) ")
F.Write(" Data.WriteLine(""Bei Änderungen nur Datum, ")
F.WriteLine(" Zeit und Meldung ändern!"") ")
F.Write(" Data.WriteLine(""Die Stellen dürfen ")
F.WriteLine(" dabei nicht geändert werden !!!"") ")
F.WriteLine(" Data.Write(Now&"" :: ""&""Wecker ""&Nr(i)) ")
F.WriteLine(" Data.WriteLine("" klingelt am ""&Tag(i)) ")
F.Write(" Data.WriteLine(""um ""&Zeit(i) ")
F.WriteLine(" &"" Uhr und meldet dann """" ""&Mdg(i)&"" """""") ")
F.WriteLine(" Data.Close ")
F.WriteLine(" Set Data=Nothing ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" 'Falls Suchschleife gestartet werden soll: ")
If Schalt = "1" then 'Wenn Suchschleife noch nicht läuft!
F.WriteLine(" ")
F.WriteLine(" Wss.Run DatX ")
F.WriteLine(" Schluss ")
F.WriteLine(" ")
End If
F.WriteLine(" ")
F.WriteLine(" Schluss2 ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" Sub Eintraege ")
F.WriteLine(" ")
F.WriteLine(" Txt=""<Fieldset>"" ")
F.WriteLine(" Txt=Txt&""<BR>"" ")
F.WriteLine(" Txt=Txt&""<Center>"" ")
F.Write(" Txt=Txt&""<Input Type=""""Text"""" Id=""""Tg1"""" ")
F.Write(" Style=""""Width:63"""" Name=""""Tag1"""" Value="""""" ")
F.Write(" &Left(Now,6)&""""""> um <Input Type=""""Text"""" ")
F.Write(" Id=""""Zt1"""" Style=""""Width:60"""" Name=""""Zeit1"""" ")
F.Write(" Value=""""""&Mid(Now,12,5)&""""""> Uhr <Input ")
F.Write(" Type=""""Text"""" Id=""""Md1"""" Style=""""Width:220"""" ")
F.WriteLine(" Name=""""Meldung1"""" Value="""""""">"" ")
F.WriteLine(" Txt=Txt&""</Center>"" ")
F.WriteLine(" Txt=Txt&""</Fieldset>"" ")
F.WriteLine(" Document.All.Meldung1.InnerHTML=Txt ")
F.WriteLine(" ")
F.WriteLine(" Txt=""<Fieldset>"" ")
F.WriteLine(" Txt=Txt&""<Center>"" ")
F.Write(" Txt=Txt&""<Input Type=""""Text"""" Id=""""Tg2"""" ")
F.Write(" Style=""""Width:63"""" Name=""""Tag2"""" Value="""""" ")
F.Write(" &Left(Now,6)&""""""> um <Input Type=""""Text"""" ")
F.Write(" Id=""""Zt2"""" Style=""""Width:60"""" Name=""""Zeit2"""" ")
F.Write(" Value=""""""""> Uhr <Input ")
F.Write(" Type=""""Text"""" Id=""""Md2"""" Style=""""Width:220"""" ")
F.WriteLine(" Name=""""Meldung2"""" Value="""""""">"" ")
F.WriteLine(" Txt=Txt&""</Center>"" ")
F.WriteLine(" Txt=Txt&""</Fieldset>"" ")
F.WriteLine(" Document.All.Meldung2.InnerHTML=Txt ")
F.WriteLine(" ")
F.WriteLine(" Txt=""<Fieldset>"" ")
F.WriteLine(" Txt=Txt&""<Center>"" ")
F.Write(" Txt=Txt&""<Input Type=""""Text"""" Id=""""Tg3"""" ")
F.Write(" Style=""""Width:63"""" Name=""""Tag3"""" Value="""""" ")
F.Write(" &Left(Now,6)&""""""> um <Input Type=""""Text"""" ")
F.Write(" Id=""""Zt3"""" Style=""""Width:60"""" Name=""""Zeit3"""" ")
F.Write(" Value=""""""""> Uhr <Input ")
F.Write(" Type=""""Text"""" Id=""""Md3"""" Style=""""Width:220"""" ")
F.WriteLine(" Name=""""Meldung3"""" Value="""""""">"" ")
F.WriteLine(" Txt=Txt&""</Center>"" ")
F.WriteLine(" Txt=Txt&""</Fieldset>"" ")
F.WriteLine(" Document.All.Meldung3.InnerHTML=Txt ")
F.WriteLine(" ")
F.WriteLine(" Txt=""<Fieldset>"" ")
F.WriteLine(" Txt=Txt&""<Center>"" ")
F.Write(" Txt=Txt&""<Input Type=""""Text"""" Id=""""Tg4"""" ")
F.Write(" Style=""""Width:63"""" Name=""""Tag4"""" Value="""""" ")
F.Write(" &Left(Now,6)&""""""> um <Input Type=""""Text"""" ")
F.Write(" Id=""""Zt4"""" Style=""""Width:60"""" Name=""""Zeit4"""" ")
F.Write(" Value=""""""""> Uhr <Input ")
F.Write(" Type=""""Text"""" Id=""""Md4"""" Style=""""Width:220"""" ")
F.WriteLine(" Name=""""Meldung4"""" Value="""""""">"" ")
F.WriteLine(" Txt=Txt&""</Center>"" ")
F.WriteLine(" Txt=Txt&""</Fieldset>"" ")
F.WriteLine(" Document.All.Meldung4.InnerHTML=Txt ")
F.WriteLine(" ")
F.WriteLine(" Txt=""<Fieldset>"" ")
F.WriteLine(" Txt=Txt&""<Center>"" ")
F.Write(" Txt=Txt&""<Input Type=""""Text"""" Id=""""Tg5"""" ")
F.Write(" Style=""""Width:63"""" Name=""""Tag5"""" Value="""""" ")
F.Write(" &Left(Now,6)&""""""> um <Input Type=""""Text"""" ")
F.Write(" Id=""""Zt5"""" Style=""""Width:60"""" Name=""""Zeit5"""" ")
F.Write(" Value=""""""""> Uhr <Input ")
F.Write(" Type=""""Text"""" Id=""""Md5"""" Style=""""Width:220"""" ")
F.WriteLine(" Name = """"Meldung5"""" Value = """""""">"" ")
F.WriteLine(" Txt=Txt&""</Center>"" ")
F.WriteLine(" Txt=Txt&""</Fieldset>"" ")
F.WriteLine(" Document.All.Meldung5.InnerHTML=Txt ")
F.WriteLine(" ")
F.WriteLine(" Txt=""<Fieldset>"" ")
F.WriteLine(" Txt=Txt&""<Center>"" ")
F.Write(" Txt=Txt&""<Input Type=""""Text"""" Id=""""Tg6"""" ")
F.Write(" Style=""""Width:63"""" Name=""""Tag6"""" Value="""""" ")
F.Write(" &Left(Now,6)&""""""> um <Input Type=""""Text"""" ")
F.Write(" Id=""""Zt6"""" Style=""""Width:60"""" Name=""""Zeit6"""" ")
F.Write(" Value=""""""""> Uhr <Input ")
F.Write(" Type=""""Text"""" Id=""""Md6"""" Style=""""Width:220"""" ")
F.WriteLine(" Name=""""Meldung6"""" Value="""""""">"" ")
F.WriteLine(" Txt=Txt&""</Center> <BR>"" ")
F.WriteLine(" Txt=Txt&""</Fieldset>"" ")
F.WriteLine(" Document.All.Meldung6.InnerHTML=Txt ")
F.WriteLine(" ")
F.WriteLine(" Txt="""" ")
F.WriteLine(" Txt=""<Fieldset><BR>"" ")
F.WriteLine(" Txt=Txt&XYZ&""<Input Checked Type=""""Radio"""" ""&_ ")
F.WriteLine(" ""Name=""""R1"""" ID=""""Opt1""""> Die ""&_ ")
F.WriteLine(" ""Termin-Meldungen speichern ! <BR>"" ")
F.WriteLine(" Txt=Txt&XYZ&""<Input Type=""""Radio"""" ""&_ ")
F.WriteLine(" ""Name=""""R1"""" ID=""""Opt0""""> Die ""&_ ")
F.WriteLine(" ""Dauer-Suchschleife neu starten !<BR>"" ")
F.WriteLine(" Txt=Txt&XYZ&""<Input Type=""""Radio"""" ""&_ ")
F.WriteLine(" ""Name=""""R1"""" ID=""""Opt2""""> Alle ""&_")
F.WriteLine(" ""vorliegenden Meldungen löschen !<BR>""")
F.WriteLine(" Txt=Txt&XYZ&""<Input Type=""""Radio"""" ""&_ ")
F.WriteLine(" ""Name=""""R1"""" ID=""""Opt3""""> Nur ""&_ ")
F.WriteLine(" ""abgelaufene Meldungen löschen !<BR>"" ")
F.WriteLine(" Txt=Txt&XYZ&""<Input Type=""""Radio"""" ""&_ ")
F.WriteLine(" ""Name=""""R1"""" ID=""""Opt4""""> Mel""&_ ")
F.WriteLine(" ""dungen abändern oder löschen !<BR>"" ")
F.WriteLine(" Txt=Txt&""<BR>"" ")
F.WriteLine(" Txt=Txt&""</Fieldset>"" ")
F.WriteLine(" Document.All.Loeschen.InnerHTML=Txt ")
F.WriteLine(" ")
F.WriteLine(" 'Falls beim PC-Neustart Meldungen vorliegen ")
F.WriteLine(" '****************************************** ")
F.WriteLine(" If Fso.FileExists(Dat0&""Termine\Start.txt"") then _ ")
F.WriteLine(" MsgBox UV&""Bitte die """" Suchschleife """" für das""&UV&_ ")
F.WriteLine(" ""Termine - Melden jetzt starten ! ""&UV&_ ")
F.WriteLine(" ""Es liegen noch Meldungen vor !""&UV, _ ")
F.WriteLine(" VbInformation+VbSystemModal, _ ")
F.WriteLine(" "" Suchschleife starten !"" ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '************************************")
F.WriteLine(" ")
F.WriteLine(" </Script> ")
F.WriteLine(" </Head> ")
F.WriteLine(" ")
F.WriteLine(" <Body OnLoad=""Eintraege"" bgcolor=""#f0e68c""> ")
F.WriteLine(" <Form> ")
F.WriteLine(" ")
F.WriteLine(" <BR> ")
F.WriteLine("<H2 Align=""Center"">Datum, Zeiten und Meldungen eintragen : ")
F.WriteLine(" <Table Border=""6"" Cellspacing=""10px"" Width=""88%""> ")
F.WriteLine(" <Tr>")
F.WriteLine(" <Td bgcolor=#90ee90> ")
F.WriteLine(" ")
F.WriteLine(" <Div Id=Meldung1></Div> ")
F.WriteLine(" <Div Id=Meldung2></Div> ")
F.WriteLine(" <Div Id=Meldung3></Div> ")
F.WriteLine(" <Div Id=Meldung4></Div> ")
F.WriteLine(" <Div Id=Meldung5></Div> ")
F.WriteLine(" <Div Id=Meldung6></Div> ")
F.WriteLine(" <Div Id=Loeschen></Div> ")
F.WriteLine(" ")
F.WriteLine(" <Center> ")
F.WriteLine(" <BR> ")
F.Write(" <Input Type=""Button"" Name=""Start"" ")
F.WriteLine( "Value=""Ausführen"" OnClick=""Weiter""> ")
F.WriteLine( " ")
F.Write(" <Input Type=""Button"" Name=""Ende"" ")
F.WriteLine(" Value=""Abbrechen"" OnClick=Schluss2> ")
F.WriteLine(" <BR><BR> ")
F.WriteLine(" </Center> ")
F.WriteLine(" ")
F.WriteLine(" </Td> ")
F.WriteLine(" </Tr> ")
F.WriteLine(" </Table> ")
F.WriteLine(" </Form> ")
F.WriteLine(" </Body> ")
F.WriteLine(" </Html> ")
F.WriteLine(" ")
F.Close
Set F=Nothing
'************************************************
' *
' Die erste geschriebene H-t-a-Datei aufrufen, *
' die 2. auf Wunsch aus ihr heraus aufgerufen : *
' *
'************************************************
'Falls beim PC-Neustart noch Meldungen vorliegen:
'************************************************
If Fso.FileExists(Dat0&"Termine\Start.txt") then
Wss.Run Dat0&"Termine\Meldung."&"h"&"t"&"a"
else
Wss.Run Dat0&"Termine\Info."&"h"&"t"&"a", , true
' "true" heißt : erst weiter, wenn beendet!
End If
'Falls Abbruch mit "X" oben rechts erfolgt ist, ist Ab-
'bruch nur möglich, wenn bei Neudurchlauf Datei0 fehlt!
'******************************************************
WScript.Sleep 1300
If (Fso.FileExists(Datei0) and Schalt="0") then _
Fso.DeleteFile(Datei0)
'(Falls Schalt=0, d.h. Suchschleife fehlt, die starten)
'1. Abschnitt mit den H-t-a-Dateien schließen, 1. H-t-a -
'Datei löschen, die gesamte Vbs-Datei erneut durchlaufen!
'********************************************************
WScript.Sleep 1000
If Fso.FileExists(Datei01) then Fso.DeleteFile(Datei01)
If Fso.FileExists(Dat0&"Termine/Start.txt") then _
Fso.DeleteFile(Dat0&"Termine/Start.txt")
WScript.Quit
End If
'################################################
'Das Ende des Abschnittes mit den H-t-a-Dateien !
'Zur Sicherheit prüfen, ob was zu löschen übrig:
'***********************************************
Datei0=Dat0&"Termine\Meldung."&"h"&"t"&"a"
Datei01=Dat0&"Termine\Info."&"h"&"t"&"a"
If Fso.FileExists(Datei0) then Fso.DeleteFile(Datei0)
If Fso.FileExists(Datei01) then Fso.DeleteFile(Datei01)
If Fso.FileExists(Dat0&"Termine/Start.txt") then _
Fso.DeleteFile(Dat0&"Termine/Start.txt")
'Beim Start Zeitmeldung schreiben, damit nie Zeitlücke:
'******************************************************
DateiX=Dat0&"Termine\SuchSchleife.txt"
Set Data=Fso.OpenTextFile(DateiX,8,true)
Data.WriteLine(Now)
Data.Close
Set Data=Nothing
WScript.Sleep 1000
'Ständige Prüfschleife, ob aktuelle Meldungen anfallen:
'******************************************************
Multi="1"
Korr="0"
Such="1"
Do until Such>1000000 'Reicht für ca. 1/3 Jahr Laufzeit!
'In 5,10,55,125,225,355,515 Min. melden, Suchschleife da!
'********************************************************
Produkt=60*Multi ' Der Divisor für die Modulo-Bildung
'Such läuft weiter, muss durch ständige Mod-Bildung auf Neu-
'start 1 gebracht werden, angepasst an wachsende Zeiträume !
'Ein Anwachsen des Melde-Abstandes bis 10 Std. ermöglichen:
'**********************************************************
If Such<3700 then
If (Such-Korr-30) mod Produkt="0" then
Wss.Popup UV&" Die Suchschleife für das"&UV&" "&_
"Termine - Melden läuft ! "&UV,2," "&_
" Die Suchschleife läuft !",VbInformation+VbSystemModal
' *************
' Mit "VbSystemModal" wird die Meldung immer nach vorne gerückt!
Multi=3+Multi
Korr=Korr+Produkt
End If
End If
'Ca. stündlich SuchSchleife.txt löschen, neu starten:
'****************************************************
If Such mod 400=0 then
If Fso.FileExists(DateiX) then Fso.DeleteFile(DateiX)
Wscript.Sleep 1000
End If
'Rückmeldungen, dass die "Suchschleife.txt" läuft:
'*************************************************
Set Data=Fso.OpenTextFile(DateiX,8,true )
Data.WriteLine(Now)
Data.Close
Set Data=Nothing
'Erst nach Rückmeldung unterbrechen, sonst Fehler bei Überprü-
'fung der " Suchschleife.txt " bei "längerer" MsgBox möglich !
'*************************************************************
'Immer Schleife von 10 s Dauer schaffen, nie länger!
'***************************************************
If Such<3700 then 'Korr wieder zurücksetzen (-Produkt)!
If (Such+1-Korr-30) mod Produkt<>"0" then _
WScript.Sleep 10000
If (Such+1-Korr-30) mod Produkt="0" then _
WScript.Sleep 7000 ' Wegen der Popup-Meldung von 3 s
Else
WScript.Sleep 10000
End If
'Prüfen, ob eine aktuelle Meldung vorliegt:
'******************************************
Menge="0" 'Kontrolle, ob Meldungen laufen
i=1
Do until (i>50 or Meldng="1")
Meldng="0"
If Fso.FileExists(Dat0&"Termine\Wecker"&i&".txt") then
Menge=1+Menge
Set Data=Fso.OpenTextFile(Dat0&"Termine"&"\Wecker"&i&".txt")
k=1
Do until Data.AtEndOfStream
ReDim Preserve Zeile(k)
Zeile(k)=Data.ReadLine
k=k+1
Loop
Data.Close
Set Data=Nothing
Datum=Right(Zeile(3),6)
Zeit=Mid(Zeile(4),4,5 )
Melden = Right(Zeile(4),Len(Zeile(4))-29)
If (Mid(Now,12,5)>= Zeit and Left(Now,6)=Datum) then
Meldng="1" ' Meldung erkannt!
Numr=i '*****************
End If
End If
i=i+1
Loop
'Bei keinen Meldungen, Suchschleife stoppen:
If Menge="0" then WScript.Quit
'Beginn des Melde-Mechanismus, falls Meldung gefunden:
'*****************************************************
If Meldng="1" then ' < xxxxxxxxxxxxxxxxxx s.u.
'Meldung muss immer in den Vordergrund gerückt werden:
'*****************************************************
MsgBox UV&UV&VbTab&Melden&" "&_
UV&UV,VbInformation+VbSystemModal,Titel
' *************
'Die Protokoll- Notiz in Programme\Schmelz.W löschen:
'****************************************************
If Fso.FileExists(Dat0&"Termine"&"\Wecker"&Numr&".txt") then _
Fso.DeleteFile(Dat0&"Termine"&"\Wecker"&Numr&".txt")
'Wenn keine Meldungen zurück, Suchschleife schließen:
'****************************************************
Lauf="0"
Set Ort=Fso.GetFolder(Dat0&"\Termine").Files
For each File in Ort
If Left(Fso.GetFileName(File),4)="Weck" then Lauf="1"
Next
If Lauf="0" then
If Fso.FileExists(Dat0&"Termine"&"\SuchSchleife.txt") then _
Fso.DeleteFile(Dat0&"Termine"&"\SuchSchleife.txt")
WScript.Quit
End If
'C:\Programme\Schmelz.W\TermineMelden erneut aufräumen:
'******************************************************
If Fso.FileExists(Dat0&"Termine/Meldung."&"h"&"t"&"a") then _
Fso.DeleteFile(Dat0&"Termine/Meldung."&"h"&"t"&"a")
If Fso.FileExists(Dat0&"Termine/Start.txt") then _
Fso.DeleteFile(Dat0&"Termine/Start.txt")
Meldng="0" ' Melde-Mechanismus beenden!
End If ' < xxxxxxxxxxxxxxxxxxx s.o.
'Ende der ständig laufenden SuchSchleife (nach 1/3 Jahr!)
'********************************************************
Such=1+Such
Loop
'Falls mögliches 1/3 Jahr für Schleife um ist!?
'**********************************************
MsgBox UV&VbCR&"Die Laufzeit von ""TermineMelden.vbs"" lief"&_
" ab !"&UV&"Bitte dieses Programm einfach neu "&_
"starten ! "&UV&VbCR,VbCritical,Titel
WScript.Quit
#########################################################################
>>> text-in-80-zeichen-je-zeile.vbs <<<
'v6.1 ==========================================================================================
'
' NAME: text-in-80-zeichen-je-zeile.vbs
'
' AUTOR: Michael Wende - wende@helimail.de
' dieseyer.de
' DATUM: 08.01.06
'
' KOMMENTAR: Übernimmt man markierten Text aus dem Internet-Browser z.B. in Notepad,
' stören oft die fehlenden Zeilenümbrüche (Zeilen mit mehr als 100 Zeichen).
' Um die Darstellung auf max. 80 Zeichen pro Zeile zu begrenzen, entstand
' dieses Skript.
'
' Arbeitsweise:
' Das Skript liest eine Datei ein und speichert diese mit max. 80 Zeichen
' pro Zeile. Die temporäre (Ausgabe-) Datei hat den Namen der Ursprungsdatei,
' wobei am Ende des Dateinamens (ohne Erweiterung) ein Kleinbuchstabe a ... z
' angehängt wird. Zum Schluß wird die Ursprungsdatei durch die temporäre Datei
' überschrieben.
'
'==================================================================================================
Dim myfsObject,textziel, thefiles
Public outfile,arg,strTitleText,strErrText
Set myfsObject=CreateObject("Scripting.FileSystemObject")
Set oFs=CreateObject("Scripting.FileSystemObject")
Set thefiles = CreateObject("Scripting.Dictionary")
arg = BrowseForFile("Bitte (Text)Datei auswählen!","Dateiwahl")
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
' Scripting.Dictionary Anwendung:
thefiles.Add "a", arg ' nimmt die Ursprungsdatei in "a" und
thefiles.Add "b",readFile(arg) ' die umformatierte Datei in "b" auf
On Error Resume Next
oFs.CopyFile thefiles.Item("b"), thefiles.Item("a"),True
If Err.Number Then
strTitleText = "Es ist mir unmöglich die Datei zu kopieren"
strErrText = "Fehler beim Kopieren von '" & thefiles.Item("b") & "' nach '" & thefiles.Item("a") & "'" & vbCRLF & vbCRLF
strErrText = strErrText & "VBScript Fehler ist aufgetreten:" & vbCRLF
strErrText = strErrText & "Fehlernr. = " & Err.Number & vbCRLF
strErrText = strErrText & "Fehlerbeschreibung: = " & Err.Description & vbCRLF
strErrText = strErrText & "Kontexthilfe = " & Err.Helpdcontext & vbCRLF
strErrText = strErrText & "Hilfepfad = " & Err.Helppath & vbCRLF
strErrText = strErrText & "eigentlicher Fehler = " & Err.Nativeerror & vbCRLF
strErrText = strErrText & "Quelle = " & Err.Source & vbCRLF
MsgBox strErrText, vbOKOnly + vbInformation, strTitleText
Err.Clear
End If
MsgBox "Alle Dateisätze verarbeitet.Programm wird beendet."
' Ende des Programmes
' ********* Start Funktionen und Unterprogramme (Subs) **********************************************************
Public Function WordWrap(ByVal strText, ByVal Laenge)
If isNumeric(Laenge) Then
If Laenge > 0 Then
If len(strText) > Laenge Then
WordWrap = left(strText, instrrev(strText," ",Laenge)) '-1)
Else
WordWrap = strText
End If
End If
End If
End Function
Public Function readFile(fname)
Dim Insatz,oFS,oFile,inputfile,neudatei
Dim reststring,restlaenge,rz,copyofinsatz,Insatzlen
outfile=MakeNewFile (fname) ' Ausgabedatei erstellen
neudatei=outfile
Set oFS = CreateObject("Scripting.FileSystemObject")
Set outfile=oFS.CreateTextFile(outfile, 1) ' Ausgabedatei öffnen
Set oFile = oFS.GetFile(fname)
Set inputfile = oFile.OpenAsTextStream ' Eingabedatei öffnen
do while not inputfile.AtEndOfStream ' bis Ende Eingabedatei lesen und neue Ausgabedatei erstellen und
Insatz = inputfile.ReadLine ' mit 80 Zeichen pro Zeile beschreiben.
Insatzlen = Len(Insatz)
copyofinsatz = Insatz
restlaenge=0 : reststring="" : rz=0
While rz < (Insatzlen-1)
reststring=WordWrap(copyofinsatz,80)
outfile.WriteLine reststring '& vbCrlf würde zusätzliche Leerzeilen schaffen
rz = rz + Len(reststring)
restlaenge = Insatzlen - rz
If restlaenge = 0 Then
' tue nichts
else
copyofinsatz = Mid(Insatz,rz+1,restlaenge)
End If
reststring=""
Wend
Loop
outfile.Close
readFile=neudatei
End Function
Function MakeNewFile (Quelldatei)
' Erstellt aus dem Namen einer Quelldatei einen neuen Namen. Gebraucht man,wenn man zum Beispiel eine
' Datei aktualisiert hat, aber ihre Ursprungsdaten erhalten will.
' An den Dateinamen wird beim ersten Aufruf ein Kleinbuchstabe a angehängt.
'
' Beispiel: Quelldatei C:\Texte\Einladung1.doc
' wird zu: C:\Texte\Einladung1a.doc
'
' Existiert die Zieldatei C:\Texte\Einladung1a.doc schon, wird an die Zieldatei Der Kleinbuchstabe ( b ... z)
' (also C:\Texte\Einladung1b.doc u.s.w.) angehängt.
' Max. 26 Variationen einer Quelldatei sind somit möglich.
Dim fs,intZaehler,DateiN
Dim nameneu,DateiEndung
'Dim Dname
Set fs = CreateObject("Scripting.FileSystemObject")
'Dname = fs.GetDriveName(Quelldatei) ' So könnte ich das Laufwerk ausfiltern
'DateiN = fs.objFSO.getFileName(Quelldatei) ' So könnte ich den Dateinamen ausfiltern
Pfad=fs.GetParentFolderName(Quelldatei) ' Dateipfad ausfiltern
For intZaehler = 97 to 122 ' von a - z Chr(97) = a
DateiN=fs.GetBaseName(Quelldatei) ' Dateiname ohne Endung ausfiltern
DateiEndung = fs.GetExtensionName(Quelldatei) ' Dateiendung
nameneu = Pfad & DateiN & Chr(intZaehler) & "." & DateiEndung
If not fs.FileExists(nameneu) Then
MakeNewFile=nameneu
Exit Function
End If
Next
End Function
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
' ********* Ende Funktionen und Unterprogramme (Subs) **********************************************************
#########################################################################
>>> timeset.vbs <<<
' (C) 2001 by Dr. Tobias Weltner, www.scriptinternals.de
' atomuhr.vbs
' http://www.scriptinternals.de/content/4-Anwendungen/uhrzeit/atomuhr/atomuhr0.htm
' atomuhr.vbs
'
'v2.3*****************************************************
' Autor: dieseyer@gmx.de
' dieseyer.de
' Erweitert und verändert durch Service.CD@gmx.de zu timeset.vbs
' Dadurch ist es möglich die Zeit per Scheduler zu setzen:
' - PopUp... (anstatt MsgBox) - Meldungen verschwinden von selbst
' - Nur wenn die Abweichung kleiner +/- 600 Sekunden wird die Zeit autom. gesetzt.
' - Es wird eine Protokolldatei timeset.log
'
'*********************************************************
' ### DIESER TEIL AUTOMATISCH EINGESETZT, UM DAS STARTEN DES SCRIPTS ÜBER DAS INTERNET ZU VERHINDERN:
if Instr(wscript.ScriptFullName, "Temporary Internet File")>0 then if MsgBox("Öffnen Sie NIEMALS direkt ein Skript im Internet - es könnte Viren enthalten! Trotzdem öffnen und sofort ausführen?",vbYesNo+vbQuestion,"Sicherheitshinweis")=vbNo then MsgBox "Gute Entscheidung! Wiederholen Sie das Download, und speichern Sie das Skript diesmal zuerst!",vbInformation : wscript.quit
' ### ENDE AUTOMATISCHER TEIL
Dim remotedate, diff, newnow, datumjetzt, tagabweichung, zeitjetzt, sekabweichung
Dim TextX, FileOut, MaxKorrektur
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' Set wshshell = CreateObject("WScript.Shell")
Set http = GetHTTPObject
MaxKorrekt = 6000 ' max. Abweichung, bei der die Zeit autom. gesetzt wird
' ist die Abweichung größer, muss die Zeit von Hand gesetzt werden
WSCript.sleep 5*1000
Zeitzone = wshshell.RegRead("HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
If IsArray(Zeitzone) Then
HexVal = Hex(Zeitzone(3)) & Hex(Zeitzone(2)) & Hex(Zeitzone(1)) & Hex(Zeitzone(0))
Else
HexVal = Hex(Zeitzone)
End If
Zeitzone = - CLng("&H" & HexVal) / 60
' wshshell.Popup "Zeitunterschied zu GMC: " & Zeitzone & " Stunde" , 2
' MsgBox "Zeitunterschied zu GMC: " & Zeitzone & "h"
Call ZeitAnfrage()
TextX= ""
TextX= TextX & "remotedate: " & vbTab & remotedate & vbCRLF
TextX= TextX & "diff : " & vbTab & vbTab & diff & vbCRLF
TextX= TextX & "newnow : " & vbTab & newnow & vbCRLF
TextX= TextX & "datumjetzt : " & vbTab & datumjetzt & vbCRLF
TextX= TextX & "tagabweichung : " & vbTab & tagabweichung & vbCRLF
TextX= TextX & "zeitjetzt : " & vbTab & vbTab & zeitjetzt & vbCRLF
TextX= TextX & "sekabweichung : " & vbTab & sekabweichung & vbCRLF
' wshshell.Popup TextX, 5, WScript.ScriptName
If Abs( sekabweichung ) < 2 and Abs( tagabweichung ) < 2 Then
wshshell.Popup "Systemzeit ok!" & vbCRLF & "Abweichung: " & sekabweichung & " Sek.", 5, WScript.ScriptName & " - keine Korrektur", 4096 + vbInformation
TextX = newnow & " " & sekabweichung & " " & vbTab & " Sekunden Abweichung - keine Korrektur erforderlich. "
LogDatei ' Sub LogDatei
Else
If Abs( sekabweichung ) < MaxKorrekt Then
Call ZeitAnfrage()
wshshell.Run "%comspec% /k time " & zeitjetzt , 0
wshshell.Run "%comspec% /k date " & datumjetzt , 0
wshshell.Popup "Zeit wurde auf " & zeitjetzt & " gesetzt!" & vbCRLF & "Abweichung war " & sekabweichung & " Sek." , 5, WScript.ScriptName & " - Korrektur", 4096 + vbInformation
TextX = newnow & " " & sekabweichung & " " & vbTab & " Sekunden Abweichung korregiert. "
LogDatei ' Sub LogDatei
Else
zeitmsg = "Systemzeit liegt mit " & sekabweichung & " " & " Sekunden daneben. Auf " & CDate(zeitjetzt) & " einstellen?"
TextX = newnow & " " & sekabweichung & " " & vbTab & " Sekunden Abweichung - nicht korregiert. "
LogDatei ' Sub LogDatei
wshshell.Popup "Zeit wird nicht auf " & zeitjetzt & " gesetzt!" & vbCRLF & "Abweichung ist mit " & sekabweichung & " Sek zu groß." , 5, WScript.ScriptName & " - keine Korrektur!", 4096 + vbInformation
' antwort = MsgBox(zeitmsg, vbQuestion+vbSystemModal+vbYesNo, " atom_uhr_dienst.VBS")
' If antwort = vbYes then
' ZeitAnfrage
' wshshell.Run "%comspec% /c time " & zeitjetzt, 0
' End If
End If
End If
' wshshell.Popup "Fertig!" , 5 , WScript.ScriptName & " , vbInformation
' MsgBox "Fertig!", vbInformation
Function GetHTTPObject
On Error Resume Next
Set http = CreateObject("microsoft.xmlhttp")
If Err.Number <> 0 Then
wshshell.Popup "Internet Explorer 5 oder höher erforderlich!", 5, WScript.ScriptName & " - Fehler", 4096 + vbInformation
WScript.Quit
End If
err.clear
Set GetHTTPObject = http
End Function ' Function GetHTTPObject
Sub ZeitAnfrage
For zaehler = 0 to 4
http.open "GET","http://tycho.usno.navy.mil/cgi-bin/timer.pl"& Now(),false
zeit1 = Now
On Error Resume Next
http.send
If Err.Number <> 0 Then
wshshell.Popup "Es besteht keine verwendbare Verbindung zum Internet!" , 120, WScript.ScriptName & " - Fehler", 4096 + vbInformation
WScript.Quit
End If
zeit2 = Now
anfragedauer = DateDiff("s", zeit1, zeit2)
gmttime = http.getResponseHeader("Date")
' wshshell.Popup gmttime , 2 , " akt. Datum / Zeit (" & zaehler & ")", 0
' MsgBox gmttime , , " akt. Datum / Zeit (" & zaehler & ")"
gmttime = Right(gmttime, Len(gmttime) - 5)
gmttime = Left(gmttime, Len(gmttime) - 3)
If anfragedauer < 2 Then Exit For
Next
If zaehler = 4 then
wshshell.Popup "Anfrage kann nicht verarbeitet werden. Später versuchen...", 60, WScript.ScriptName & " - Fehler", 4096 + vbInformation
WScript.Quit
End If
gmttime = Replace(gmttime, " Dec ", " 12 ")
gmttime = Replace(gmttime, " Nov ", " 11 ")
gmttime = Replace(gmttime, " Oct ", " 10 ")
gmttime = Replace(gmttime, " Sep ", " 09 ")
gmttime = Replace(gmttime, " Aug ", " 08 ")
gmttime = Replace(gmttime, " Jul ", " 07 ")
gmttime = Replace(gmttime, " Jun ", " 06 ")
gmttime = Replace(gmttime, " May ", " 05 ")
gmttime = Replace(gmttime, " Apr ", " 04 ")
gmttime = Replace(gmttime, " Mar ", " 03 ")
gmttime = Replace(gmttime, " Feb ", " 02 ")
gmttime = Replace(gmttime, " Jan ", " 01 ")
remotedate = DateAdd("h", Zeitzone, gmttime)
diff = DateDiff("s",zeit1,remotedate)
newnow = DateAdd("s", diff + anfragedauer, Now)
datumjetzt = DateValue(newnow)
tagabweichung = DateDiff("d", Date, datumjetzt)
zeitjetzt = TimeValue(newnow)
zeitjetzt = Right(0 & Hour(zeitjetzt), 2) & ":" & Right(0 & Minute(zeitjetzt), 2) & ":" & Right(0 & Second(zeitjetzt), 2)
' wshshell.Popup zeitjetzt , 3 , WScript.ScriptName, 0
sekabweichung = DateDiff("s", Time, zeitjetzt)
End Sub ' Sub ZeitAnfrage
Sub LogDatei
' Set FileOut = fso.OpenTextFile("TimeSet.Log", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileOut = fso.OpenTextFile("TimeSet.Log", 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
fileOut.WriteLine (TextX)
Set FileOut = Nothing ' Datei schließen
End Sub ' Sub TimeSet.Log
#########################################################################
>>> toansi.vbs <<<
'*** v5.9 *** www.dieseyer.de *******************************
'
' Datei: toansi.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Wandelt die deutschen ASCII-Zeichen in ANSI-Zeichen.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei, Text
TmpDatei = fso.GetbaseName( WScript.ScriptName ) & ".tmp"
WSHShell.Run "%comspec% /c echo YYY daß läuft übers Öhr ÖöüÜäÄß YYY > " & TmpDatei, , True
WScript.Sleep( 333 )
Dim FileIn : Set FileIn = FSO.OpenTextFile( TmpDatei, 1 )
Text = FileIn.ReadAll
FileIn.Close
Set FileIn = Nothing
fso.DeleteFile( TmpDatei )
MsgBox "ASCII: " & vbTAb & Text & vbCRLF & "ANSI: " & vbTAb & ToANSI( Text ), 4096, WScript.ScriptName
WScript.Quit
'*** v5.9 *** www.dieseyer.de *******************************
Function ToANSI( ASCIIz )
'***********************************************************
' von Christoph Basedau aus
' http://groups.google.de/groups?q=ToANSI+%3D+Replace&hl=de&lr=&newwindow=1&selm=ugGVQok3AHA.1604%40tkmsftngp02&rnum=1
ToANSI = Replace(ASCIIz, chr(132), chr(228))
ToANSI = Replace(ToANSI, chr(129), chr(252))
ToANSI = Replace(ToANSI, chr(142), Chr(196))
ToANSI = Replace(ToANSI, chr(154), Chr(220))
ToANSI = Replace(ToANSI, chr(153), Chr(214))
ToANSI = Replace(ToANSI, chr(148), Chr(246))
ToANSI = Replace(ToANSI, chr(225), Chr(223))
End Function ' ToANSI( ASCIIz )
#########################################################################
>>> toansi2.vbs <<<
'*** v3.6 *** www.dieseyer.de *******************************
'
' Datei: toansi2.vbs
' Autor: joerg.zuehlke@gmx.de
' Auf: www.dieseyer.de
'
' Wandelt die deutschen ASCII-Zeichen in ANSI-Zeichen oder
' umgekehrt.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei, Text
TmpDatei = fso.GetbaseName( WScript.ScriptName ) & ".tmp"
WSHShell.Run "%comspec% /c echo YYY daß läuft „”Ž™šáñ¸ übers Öhr ÖöüÜäÄß YYY > " & TmpDatei, , True
WScript.Sleep( 333 )
Dim FileIn : Set FileIn = FSO.OpenTextFile( TmpDatei, 1 )
Text = FileIn.ReadAll
FileIn.Close
Set FileIn = Nothing
fso.DeleteFile( TmpDatei )
MsgBox "ASCII: " & vbTAb & Text & vbCRLF & "ANSI: " & vbTAb & Asc2Ans( Text, True ) & vbCRLF & "ASCII: " & vbTAb & Asc2Ans( Asc2Ans( Text, True ) , False ) , 4096, WScript.ScriptName
WScript.Quit
'*** v3.6 *** www.dieseyer.de *******************************
Function Asc2Ans(Txt, As2An)
'************************************************************
' von joerg.zuehlke@gmx.de
'Txt ist der umzuwandelnde Text
'As2An ist True für Umwandlung von Ascii nach Ansi
'As2An ist False für Umwandlung von Ansi nach Ascii
Dim um, s, i, j
um=Array("„”Ž™šáñ¸", "äöüÄÖÜß±©")
s=Txt
j=Abs(As2An)
For i=1 To Len(um(0))
s=Replace(s, Mid(um(1-j), i, 1), Mid(um(j), i, 1))
Next
Asc2Ans=s
End Function ' Asc2Ans(Txt, As2An)
#########################################################################
>>> trace32log.vbs <<<
'*** v9.5 *** www.dieseyer.de ******************************
'
' Datei: trace32log.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Im Gegensatz zu "logdatei.vbs", die 'nur' (Beispiel-)
' Prozeduren für den Einsatz in VBS-Dateien enthalten, kann
' dieses Skript z.B. aus Batch-Skripten heraus aufgerufen
' werden - Bacht-Skripte selbst können nur sehr umständlich
' 'schöne' LOG-Dateien für trace32.exe schreiben.
'
' trace32log.vbs erwartet drei Parameter
' 1. ErrType:
' 0 - löscht die LOG-Datei und erstellt eine neue
' 1 - normal (weißer Hintergrund)
' 2 - Zeile mit gelben Hintergrund
' 3 - Zeile mit rotem Hintergrund
' 2. LogDatei: In diese wird der Eintrag vorgenommen; dieser
' Parameter muss von " (Anführungszeichen) umschlossen sein.
' 3. LogTxt: Die Zeichenkette (mit Leerschritten) nach dem
' letzten " wird als Text in die LOG-datei geschrieben.
'
' trace32log.vbs - Aufruf aus einer Batch:
' trace32log.vbs 0 "c:\temp\bsp.log" neue LOG-Datei
' trace32log.vbs 1 "c:\temp\bsp.log" normaler LOG-Eintrag
' start trace32log.vbs 3 "%~dpn0.log" ein roter LOG-Eintrag
' trace32log.vbs 2 "%~dpn0.log" ein gelber LOG-Eintrag
' trace32log.vbs 3 "%~dpn0.log" 12 :: ein "roter" LOG-Eintrag
'
' Aus einer Batch heraus ergibt "%~dpn0.log"
' d - Laufwerksbuchstabe mit Doppelpunkt (Drvive; hier "C:")
' p - Pfad (Path; hier "\tst\"")
' n - Dateiname (Name; hier "xx")
' x - Erweiterung mit Punkt (eXtension; hier ".cmd")
' 0 - bezieht sich auf die aktuelle Datei (c:\tst\xx.cmd)
' "c:\tst\xx.cmd" => "c:\tst\xx.log"
' "\\srv1\Share9\bsp\1.cmd" =>"\\srv1\Share9\bsp\1.log"
'
' trace32.exe stammt aus
' http://support.microsoft.com/kb/272436
' http://www.microsoft.com/technet/sms/20/downloads/tools/sp2_tools_help.mspx
' zeigt sehr lange LOG-Einträge (einer Zeile) in einem
' (Status-) Fenster und in der Statuszeile die Dauer vom
' Start der LOG-Datei bis zur aktuellen LOG-Zeile.
'
' Die Zeilennummerm (z.B. "038 :: " für LOG-Dateien können
' komfortabel mit
' http://dieseyer.de/scr-html/sendenan-sicherung.html
' angepasst werden.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim oArgs : Set oArgs = Wscript.Arguments
Dim LgErr, LogDatei, LgText, i
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
' MsgBox oArgs.item(i), , i
if i = 0 then LgErr = oArgs.item(i)
if i = 1 then LogDatei = oArgs.item(i)
if i = 2 then LgText = LgText & oArgs.item(i)
if i > 2 then LgText = LgText & " " & oArgs.item(i)
Next
' MsgBox "LgErr:" & vbTab & vbTab & LgErr & vbCRLF & "LogDatei: " & vbTab & LogDatei & vbCRLF & "LgText:" & vbTab & vbTab & LgText, , "058 :: "
Call Trace32Log( LgText, LgErr )
WScript.Quit
'*** 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 )
'*** v3.9 *** www.dieseyer.de ******************************
Sub LogText( LogTxt )
'***********************************************************
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( WScript.ScriptName & ".log", 8, true ).WriteLine ( LogTxt )
End Sub ' LogText( LogTxt )
#########################################################################
>>> txtquerdruck.vbs <<<
'v3.C***********************************************************
' File: TXTQuerDruck.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' kopiert Datei(en) zum Drucker, die dann im Querformat gedruckt
' werden.
'
' ACHTUNG:
' Jedes Zeichen der Datei(en) kommt beim Drucker an. Man sollte
' also nur ASCII-Dateien (z.B. Quelltexte) verwenden, sonst werden
' !!! HUNDERTE !!! Seiten mit Schwachsinn bedruckt.
'***************************************************************
Option Explicit
Dim SendToLink, Text, TextX, i
Dim oArgs, WSHShell, fso
Dim Drucker, Datei, TmpDatei, FileOut
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
SendToLink = "Text quer drucken"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
'***************************************************************
' ANFANG des eigentlichen Skripts
'***************************************************************
Text = ""
' WSHShell.run UCase("net use lpt2 /DELETE") , 0, True
' WSHShell.run UCase("net use lpt2: \\PrintSrv\LJ4plus") , 0, True
TmpDatei = WScript.ScriptFullName & ".Tmp"
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then
Text = Left( UCase(oArgs.item(i)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
End If
If Drucker = "" then Drucker = Druckerauswahl ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & i & vbTab & oArgs.item(i) & vbTab & Drucker & vbCRLF ' Protokoll
Set FileOut = fso.OpenTextFile (TmpDatei, 2, true) ' TmpDatei neu anlegen (2)
' FileOut.WriteLine ( Chr(27) & "E" & Chr(27) & "&l1O" )
FileOut.WriteLine ( Chr(27) & "E" & Chr(27) & "&l1O" & Chr(27) & "(s16H" & Chr(27) & "&l12D" )
' | | | 12 Zeilen pro Zoll - 8, 12, 16 sind möglich
' | | 16 Zeichen pro Zoll - Schriftgröße
' | &l1O Querformat
' E DruckerReset - in Einschaltzustand zurück setzen
FileOut.WriteLine ("#-#-# => " & oArgs.item(i) & " - gedruckt am " & now() & " <= #-#-#" )
Set FileOut = nothing ' TmpDatei schließen
Text = "%comspec% /c copy /b """ & TmpDatei & """ +""" & oArgs.item(i) & """ """ & TmpDatei & """ "
' Zusammensetzen der TmpDatei: TmpDatei und zu druckende Datei
' WSHShell.Popup Text, 10, WScript.ScriptName , 64
WSHShell.run Text , 0, True
Set FileOut = fso.OpenTextFile (TmpDatei, 8, true) ' TmpDatei erweitern (8)
' FileOut.WriteLine (Text)
FileOut.WriteLine (Chr(27) & "E") ' TmpDatei mit DruckerReset-Esc-Sequenz (SeitenVorschub) (PCL)
Set FileOut = nothing ' TmpDatei schließen
' WSHShell.Popup TmpDatei & vbTab & Drucker , 10, WScript.ScriptName , 64
FSO.CopyFile TmpDatei, Drucker ' Datei zum Drucker kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = Datei & vbCRLF
Next
' if fso.FileExists (TmpDatei) then MsgBox "fso.FileDelete (" & TmpDatei & ")"
if fso.FileExists (TmpDatei) then fso.DeleteFile (TmpDatei)
'***************************************************************
' ENDE des eigentlichen Skripts
'***************************************************************
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
'***************************************************************
Sub SkriptInfo ' Sub Aufruf
'***************************************************************
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Entweder ein oder mehrere Dateien bzw. Verzeichnisse " & vbCRLF
Text = Text & "mit der 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 & "Wenn es sich nicht um TXT- oder PRN- Dateien handelt," & vbCRLF
Text = Text & "können es ! HUNDERTE ! Seiten werden!" & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & fso.GetBaseName( WScript.ScriptName ) & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
'***************************************************************
Function Druckerauswahl ' Anfanfg
'***************************************************************
' Es kann nur auf LPT? und Netzwerkdrucker kopiert werden
Dim i, n, Text, DruckerNr, NetPRN, WSHNet
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
n = 0
' welche Drucker sind verwendbar:
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
End If
Next
Text = Text & vbCRLF & "Auf welchen Drucker soll gedruckt werden?"
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
End If
If DruckerNr > n OR DruckerNr < 1 then DruckerNr = ""
If DruckerNr = "" then WSHShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
If DruckerNr = "" then WScript.Quit
n = 0
' gewählten Drucker ermitteln
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i+1)
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i )
End If
End If
Next
End Function ' Druckerauswahl
'***************************************************************
#########################################################################
>>> txtzulpt1.vbs <<<
'v2.4*****************************************************
' File: TXTzumLPT1.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Kopiert eine Datei direkt zum Drucker. Es wird jedes!!!
' Zeichen der Datei zum Drucker geschickt. Man sollte also
' nur .PRN- oder ASCII-Dateien (z.B. Quelltexte) verwenden.
'
' Es gibt Scanner, mit denen es möglich ist, den Scanner,
' zusammen mit am PC angeschlossenen Drucker, als Kopierer
' zu nutzen. Auf dem PC ist zum Standarddrucker ein wei-
' terer gleicher Drucker zu installieren, der in eine
' Datei druckt. Nutzt man jetzt die Kopierer-Funktion,
' entsteht eine Datei (mit der Endung .PRN).
'
' Ich habe das mal verwendet, um die zahlreichen Kopien
' für meine Bewerbungen mit einem Laserdrucker zu drucken.
'*********************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments ' hole Argumentsauflistung
If oArgs.Count > 0 Then ' gibt es Argumente?
Datei = oArgs.item(0) ' erstes Argument
Else
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Maus ein Datei auf das Skript ziehen und" & vbCRLF
Text = Text & "fallen lassen - JETZT wird die Datei zum Drucker" & vbCRLF
Text = Text & "an LPT1 kopiert . . ." & vbCRLF & vbCRLF
Text = Text & "Wenn es keine TXT-Datei ist, können es HUNDERTE! " & vbCRLF
Text = Text & "Seiten werden!" & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
Drucker = "\\MeinPC\Drucker"
Drucker = "\\MeinPC\Drucker"
Drucker = "LPT1:"
Drucker = InputBox ("Auf welchen Drucker soll """ & Datei & """ gedruckt werden?", WScript.ScriptName, Drucker)
If Drucker = "" then WScript.Quit
' MsgBox "Copy " & Datei & " nach " & Drucker
FSO.CopyFile Datei, Drucker
TextX = Datei & " wurde zum Drucker " & Drucker & " kopiert!" & vbCRLF & vbCRLF
TextX = TextX & "Möglicherweise muss von Hand der Seitenvorschub ausgelöst werden!"
WSHShell.Popup TextX, 15, WScript.ScriptName
#########################################################################
>>> txtzumdrucker.vbs <<<
'v3.C***********************************************************
' File: TXTzumDrucker.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Kopiert eine Datei direkt zum Drucker. Es wird jedes!!!
' Zeichen der Datei zum Drucker geschickt. Man sollte also
' nur .PRN- oder ASCII-Dateien (z.B. Quelltexte) verwenden.
'
' Es gibt Scanner, mit denen es möglich ist, den Scanner,
' zusammen mit am PC angeschlossenen Drucker, als Kopierer
' zu nutzen. Auf dem PC ist zum Standarddrucker ein wei-
' terer gleicher Drucker zu installieren, der in eine
' Datei druckt. Nutzt man jetzt die Kopierer-Funktion,
' entsteht eine Datei (mit der Endung .PRN).
'
' Ich habe das mal verwendet, um die zahlreichen Kopien
' für meine Bewerbungen mit einem Laserdrucker zu drucken.
'
' 1b 45 = 27 69 = <Esc> E = PCL-DruckerReset / Seitenvorschub
' siehe Zeile 80: FSO.CopyFile TmpDatei, Drucker
'***************************************************************
Option Explicit
Dim WSHShell, FSO, WSHNet, NetPrn, oArgs
Dim FileOut, Text, Drucker, DruckerNr, Datei, TmpDatei, i
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
set oArgs = Wscript.Arguments ' Argumente bereit stellen
If not oArgs.Count > 0 Then ' gibt es Argumente?
Text = "Das Ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Mit der Maus Datei(en) auf das Skript ziehen und" & vbCRLF
Text = Text & "fallen lassen . . . dann wird's was!" & vbCRLF & vbCRLF
Text = Text & "Wenn es sich nicht um TXT- oder PRN- Dateien handelt," & vbCRLF
Text = Text & "können es HUNDERTE ! Seiten werden!" & vbCRLF
MsgBox Text, , WScript.ScriptName
WScript.Quit
End If
If Drucker = "" then Drucker = Druckerauswahl ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~
TmpDatei = WScript.ScriptFullName & ".Tmp"
Set FileOut = fso.OpenTextFile (TmpDatei, 2, true)
FileOut.WriteLine (Chr(27) & "E") ' Datei mit Seitenvorschub-Zeichenkette erstellen
FileOut.Close
Set FileOut = nothing
' if fso.FileExists (TmpDatei) then MsgBox WScript.ScriptName & ".Tmp"
Datei = ""
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Datei = Datei & " " & oArgs.item(i) & vbCRLF ' Protokoll
FSO.CopyFile oArgs.item(i), Drucker ' Datei zum Drucker kopieren
if fso.FileExists (TmpDatei) then
' nächste Zeile nur wenn erforderlich freigeben
' FSO.CopyFile TmpDatei, Drucker ' Datei mit Seitenvorschub-Zeichenkette zum Drucker kopieren
End If
Next
' if fso.FileExists (TmpDatei) then MsgBox "fso.FileDelete (" & TmpDatei & ")"
if fso.FileExists (TmpDatei) then fso.DeleteFile (TmpDatei)
Text = Datei & "wurde(n) zum Drucker an " & Drucker & " kopiert!" & vbCRLF & vbCRLF
Text = Text & "Möglicherweise muss von Hand der Seitenvorschub ausgelöst werden!"
WSHShell.Popup Text, 15, WScript.ScriptName
'***************************************************************
Function Druckerauswahl ' Anfanfg
'***************************************************************
' Es kann nur auf LPT? und Netzwerkdrucker kopiert werden
Dim i, n, Text, DruckerNr, NetPRN, WSHNet
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
n = 0
' welche Drucker sind verwendbar:
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
End If
Next
Text = Text & vbCRLF & "Auf welchen Drucker soll gedruckt werden?"
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
End If
If DruckerNr > n OR DruckerNr < 1 then DruckerNr = ""
If DruckerNr = "" then WSHShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
If DruckerNr = "" then WScript.Quit
n = 0
' gewählten Drucker ermitteln
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i+1)
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i )
End If
End If
Next
End Function ' Druckerauswahl
'***************************************************************
#########################################################################
>>> usbporttest.vbs <<<
'*** v8.1 *** www.dieseyer.de ****************************
'
' Datei: usbporttest.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' aus
' http://www.source-center.de/forum/showthread.php?t=37854
' CMDR 080107
'
' Gibt 'BESCHEID!', wenn sich an einem der USB-ports 'etwas'
' bewegt.
'
' Allgemeines Problem der Überwachung von Events:
' Das Skript 'steht' bei der Überwachung in der Do..Loop-
' Schleife, wodurch keine (anderen) Aktionen vom Skript
' ausgelöst oder ausgewertet werden können. Also lässt sich
' das Skript nur _nach_ einem Event beenden - wie hier mit
' " If Taste = vbNo then Exit Do"
'
'*********************************************************
Option Explicit
'******** USB-Sentry.vbs CMDR 080108 *********
Dim objShell, objWMIService, colMonitoredProcesses
Dim strLatestProcess, USBDev, Taste, mld
set objShell = CreateObject( "WScript.Shell" )
objShell.PopUp "Die USB-Anschlüsse werden überwacht!", 5, "HINWEIS", vbSystemModal + vbInformation
Set objWMIService = GetObject( "Winmgmts:{impersonationLevel=impersonate}" )
Set colMonitoredProcesses = objWMIService.ExecNotificationQuery ( "SELECT * FROM __InstanceOperationEvent WITHIN 5 WHERE TargetInstance ISA ""Win32_USBHub""" )
Do
Set strLatestProcess = colMonitoredProcesses.NextEvent
USBDev=strLatestProcess.TargetInstance.Name
Select Case strLatestProcess.Path_.Class
Case "__InstanceCreationEvent"
mld = USBDev & vbLf & "wurde angeschlossen !"
Case "__InstanceModificationEvent"
mld = USBDev & vbLf & "wurde in der Einstellung geändert!"
Case "__InstanceDeletionEvent"
mld = USBDev & vbLf & "wurde abgezogen !"
End Select
' Taste = objShell.PopUp ( mld & vbLf & vbLf & " --> Überwachung fortsetzen ?", 10, "MELDUNG", vbSystemModal + vbExclamation + vbYesNo )
Taste = objShell.PopUp ( strLatestProcess.Path_.Class & vbLf & vbLf & " --> Überwachung fortsetzen ?", 10, "MELDUNG", vbSystemModal + vbExclamation + vbYesNo )
If Taste = vbNo then Exit Do
Loop
objShell.PopUp "USB-Überwachung beendet!", 5, "ENDE", vbSystemModal
#########################################################################
>>> usertempverz.vbs <<<
'*** v9.4 *** www.dieseyer.de *******************************
'
' Datei: usertempverz.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur ist Bestandteil von WinTuC_vbs.vbs (WinTuC.de)
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox UserTempVerz()
Wscript.Quit
'*** v9.4 *** 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 : 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, , "30 :: "
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, , "36 :: " : WScript.Quit
End Function ' UserTempVerz
#########################################################################
>>> vbsbeimsystemstart-84.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: vbsbeimsystemstart.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' (siehe auch "wmi-VBSalsService.vbs")
'
'
' Das Skript erwartet beim Aufruf einen PCNamen und einen
' Programmnamen (mein.vbs oder deine.cmd), auf dem der
' Dienst "1Service" erstellt werden soll, der das Programm
' beim Systemstart starten wird.
' Ist der entfernte PC erreichbar und sind die erforderlichen
' Rechte vorhanden, werden auf diesem
' - der Dienst "1Service" erstellt
' - das Skript 'VBSDienst' geschrieben
' - das Programm (in Variable 'VBSStart') dorthin kopiert
' - eine vorhandene Programmname-.INI-Datei wird auch kopiert
' (Fehlt 'VBSStart' wird als Demo eine VBS-Datei erstellt,
' die sich beim Dienststart meldet.)
' Das Skript erwartet beim Aufruf zwei Parameter: einen
' PC (-Namen) auf dem der Dienst "1Service" erstellt werden
' soll und ein Programm (-Name; z.B. 'mein.vbs' oder
' 'deine.cmd'), das beim Systemstart gestartet werden soll.
' Ist der entfernte PC erreichbar und sind die erforderlichen
' Rechte vorhanden, werden auf diesem
' - der Dienst "1Service" erstellt
' - das Skript 'VBSDienst1' geschrieben
' - das Skript 'VBSDienst' geschrieben
' - das Programm (in Variable 'VBSStart') dorthin kopiert
' - vorhandene Programmname.* - Datei(en) werden kopiert
' (Fehlt 'VBSStart' wird als Demo eine VBS-Datei erstellt,
' die sich beim Dienststart meldet.)
'
' Der Dienst "1Service" starte auf dem entfernten PC bei
' jedem Systemstart (vor einer Benutzeranmeldung) das Skript
' 'VBSDienst'. Dieses prüft, ob der Dienst "1Service"
' entfernt oder ob das Programm 'VBSStart' aufgerufen werden
' soll - diese Steuerung ist in 'VBSDienst' implementiert
' und vom Vorhandensein verschiedener Dateien abhängig:
' Der Dienst "1Service" startet das Skript 'VBSDienst1' auf
' dem entfernten PC (sofort und dann) bei jedem Systemstart
' vor einer Benutzeranmeldung - 'VBSDienst1' ruft 'VBSDienst'
' auf. Dieses prüft, ob der Dienst "1Service" entfernt oder
' ob das Programm 'VBSStart' aufgerufen werden soll - diese
' Steuerung ist in 'VBSDienst' implementiert und vom
' Vorhandensein verschiedener Dateien abhängig:
'
' - es existiert 'VBSStart' mit der Dateiendung (eXtension)
' ".no" (z.B. statt ".vbs"): 'VBSStart' wird nicht
' gestartet; der "1Service" bleibt erhalten.
'
' - es existiert 'VBSStart' mit der Dateiendung ".boot":
' statt 'VBSStart' wird der PC nach 3min neu gestartet;
' der "1Service" bleibt erhalten.
'
' - es existiert 'VBSStart' mit der Dateiendung ".end" oder
' - es fehlt das Skript 'VBSStart':
' Der Dienst "1Service" wird gelöscht bzw. entfernt.
'
' Z.B. wenn 'VBSStart' seine Aufgaben erfüllt hat, löscht
' es sich selbst und beim nächsten Systemstart wird der
' Dienst "1Service" von 'VBSDienst' entfernt. Oder wenn
' 'VBSStart' seine Aufgaben erfüllt hat, schreibt 'VBSStart'
' eine dieser Dateien; beim nächsten Systemstart . . .
'
' Da das Skript 'VBSDienst1' kein richtiger Dienst sein kann,
' wird es vom Dienstmanager nach 30s beendet - mit einem
' Fehlereintrag in der Ereignisanzeige.
' Dieses Skript ist eine Erweiterung bzw. Ablösung von
' "wmi-vbsalsservice.vbs" ab.
'
'************************************************************
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
Const VBSDienst1 = "VBSdienst1.vbs" ' wird von 'Dienst1' gestartet
Const VBSDienst = "VBSdienst.vbs" ' wird von 'VBSDienst1' gestartet und startet 'VBSDienst'
Const VBSVerz = "DatenVerz" ' dieses Verz. wird auf den entfernten PC kopiert
Dim VBSStart ' das Skript / die Batch / das Programm, das vom Dienst gestartet werden soll
Dim ZielPC
Dim ZielVerz, ZielWinDir, ZielDatei, Txt, Tst
' MsgBox vbTab & "START", , "0097 :: " & WScript.ScriptName
' Parameter auswerten
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Es muss ein PCName als Parameter übergeben werden
If oArgs.Count = 0 Then
SkriptInfo( "0104 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
ZielPC = UCase( oArgs.item( 0 ) )
If oArgs.Count > 1 Then VBSStart = LCase( oArgs.item( 1 ) )
If Len( ZielPC ) > 15 Then
SkriptInfo( "Der PCName ist zu lang! " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' 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 "0136 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "0137 :: LogDatei: " & LogDatei, 1
Trace32Log "0138 :: AktVerz: " & AktVerz, 1
Trace32Log "0139 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "0140 :: Angemeldeter User: " & WSHNet.UserName, 1
Trace32Log "0141 :: ZielPC: " & ZielPC, 1
' ZielPC erreichbar?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not WMIpingOK( ZielPC ) Then
Txt = "ZielPC """ & ZielPC & """ ist nicht erreichbar."
Trace32Log "0148 :: " & Txt, 2
WSHShell.Popup now() & vbCRLF & Txt, 15, "0149 :: " & "= = = E N D E = = ="
Trace32Log "0150 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0152 :: " & "= = = E N D E = = ="
WScript.Quit
End If
Txt = "ZielPC ist per WMI-Ping erreichbar: " & ZielPC : Trace32Log "0155 :: " & Txt, 1 : ' WSHShell.Popup now() & vbCRLF & Txt, 5, "0155 :: " & "= = = E N D E = = ="
Call VerzZielPC ' prüft Verzeichnisse und erstellt ggf. welche
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ZielSkripteErstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielDatei = "wscript.exe " & ZielWinDir & "\Temp\dieseyer.de\" & VBSDienst1
Trace32Log "0168 :: Service auf """ & ZielPC & """ erstellen", 1
Trace32Log "0169 :: Service startet """ & ZielDatei & """ ", 1
'Call ServiceEntfernen( ZielPC, Dienst1 ) : WScript.Quit ' Für Tests
Call ServiceErstellen( ZielPC, Dienst1, Zieldatei )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ServiceStarten( ZielPC, Dienst1 )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Call ServiceEntfernen( ZielPC, Dienst1 )
' wird 'eigentlich' vom entfernten PC selbst aufgerufen
' Prozedur wird in 'VBSDienst' eingefügt
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & "Patchinstallationen beginnen mit einem Reboot auf " & vbCRLF & vbCRLF & vbTab & ZielPC, 7, "0184 :: " & WScript.ScriptName
' WSHShell.Popup "= = = E N D E = = =", 2, "0185 :: " & WScript.ScriptName
Trace32Log "0186 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
LogDatei = "" : Trace32Log "Abgearbeitet: """ & ZielPC & """ " , 1 ' LOG-Datei ist VBS-Name
WScript.Quit
'*********************************************************
Sub VerzZielPC()
'*********************************************************
' %WinDir% auf ZielPC ermitteln
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielWinDir = RemoteWinDir( ZielPC )
' Trace32Log "0200 :: 'ZielWinDir': " & ZielWinDir, 1
If InStr( ZielWinDir, "FEHLER:" ) = 1 Then
Txt = "'ZielWinDir' auf """ & ZielPC & """ kann nicht ermittelt werden: " & ZielWinDir
Trace32Log "0203 :: " & Txt, 2
WSHShell.Popup now() & vbCRLF & Txt, 15, "0204 :: " & "= = = E N D E = = ="
Trace32Log "0205 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0207 :: " & "= = = E N D E = = ="
WScript.Quit
End If
Trace32Log "0210 :: 'ZielWinDir' auf """ & ZielPC & """ ist " & ZielWinDir, 1
' Mit ZielPC verbinden
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = ZielWinDir
'' Txt = "%WinDIR% des ZielPC ist: """ & ZielVerz & "\"" "
'' Trace32Log "0217 :: " & Txt, 1
'' Txt = Mid( ZielVerz, 3 )
ZielVerz = "\\" & ZielPC & "\" & Mid( ZielVerz, 1, 1 ) & "$" & Mid( ZielVerz, 3 )
If fso.FolderExists( ZielVerz ) Then
Else
Txt = "Verzeichnis ist nicht erreichbar: """ & ZielVerz & "\"" "
Trace32Log "0224 :: " & Txt, 2
WSHShell.Popup now() & vbCRLF & Txt, 15, "0225 :: " & "= = = E N D E = = ="
Trace32Log "0226 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0228 :: " & "= = = E N D E = = ="
WScript.Quit
End If
Trace32Log "0231 :: Auf """ & ZielPC & """ erreichbar: " & ZielVerz, 1
' Auf ZielPC %WinDir%\Temp erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = ZielVerz & "\Temp"
If fso.FolderExists( ZielVerz ) Then
Trace32Log "0238 :: Verzeichnis existiert: """ & ZielVerz & "\"" " , 1
Else
Trace32Log "0240 :: Verzeichnis wird angelegt: " & ZielVerz & "\"" " , 1
On Error Resume Next
err.Clear
fso.CreateFolder ZielVerz
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
Txt = "Verzeichnis kann nicht angelegt werden: """ & ZielVerz & "\"" "
Trace32Log "0248 :: " & Txt, 2
Trace32Log "0249 :: " & Tst, 3
WSHShell.Popup now() & vbCRLF & Txt, 15, "0250 :: " & "= = = E N D E = = ="
Trace32Log "0251 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0253 :: " & "= = = E N D E = = ="
WScript.Quit
End If
End If
Trace32Log "0257 :: Auf """ & ZielPC & """ erreichbar: " & ZielVerz, 1
' Auf ZielPC %WinDir%\Temp\dieseyer.de erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = ZielVerz & "\dieseyer.de"
If fso.FolderExists( ZielVerz ) Then
Trace32Log "0264 :: Verzeichnis existiert: " & ZielVerz & "\"" " , 1
Else
Trace32Log "0266 :: Verzeichnis wird angelegt: " & ZielVerz & "\"" " , 1
On Error Resume Next
err.Clear
fso.CreateFolder ZielVerz
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
Txt = "Verzeichnis kann nicht angelegt werden: """ & ZielVerz & "\"" "
Trace32Log "0274 :: " & Txt, 2
Trace32Log "0275 :: " & Tst, 3
WSHShell.Popup now() & vbCRLF & Txt, 15, "0276 :: " & "= = = E N D E = = ="
Trace32Log "0277 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0279 :: " & "= = = E N D E = = ="
WScript.Quit
End If
End If
Trace32Log "0283 :: Auf """ & ZielPC & """ erreichbar: " & ZielVerz & "\"" ", 1
' Schreibtest auf ZielPC
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
err.Clear
fso.OpenTextFile( ZielVerz & "\dummy.tmp", 8, True ).WriteLine ( "TEST" )
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
Txt = "In Verzeichnis kann nicht geschrieben werden: """ & ZielVerz & "\"" "
Trace32Log "0295 :: " & Txt, 2
Trace32Log "0296 :: " & Tst, 3
WSHShell.Popup now() & vbCRLF & Txt, 15, "0297 :: " & "= = = E N D E = = ="
Trace32Log "0298 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0300 :: " & "= = = E N D E = = ="
WScript.Quit
End If
fso.DeleteFile ZielVerz & "\dummy.tmp", True
' Schreibtest auf ZielPC - Info-Datei erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = ZielVerz & "\" & Dienst1 & ".txt" ' : MsgBox Tst, , "0307 :: "
Call TempHilfeTxt( Tst )
End Sub ' VerzZielPC()
'*********************************************************
Sub ZielSkripteErstellen
'*********************************************************
Dim Tst, Txt, Tyt
' Skript / Programm "VBSStart" auf ZielPC bereitstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( VBSStart ) = 0 Then
' wenn kein zu startendes Programm als Parameter an
' dieses Skipt übergeben wurde: VBS für Tests erstellen
VBSStart = "VBSStart.vbs" ' als Beispiel
' ZielDatei = ZielVerz & "\" & VBSStart
Trace32Log "0325 :: Soll erstellt werden: """ & ZielDatei & """ " , 1
Txt = "MsgBox now() & vbTab & "". . . . hier bin ich:"" & vbCRLF & vbCRLF & WScript.ScriptFullName, , WScript.ScriptName"
' fso.OpenTextFile( VBSDienst, 2, True ).Write( Txt ) ' für Tests, ins aktuelle Verz.
fso.OpenTextFile( ZielDatei, 2, True ).Write( Txt ) ' 2: löschen und neu erstellen
Trace32Log "0329 :: Ist erstellt: """ & ZielDatei & """ " , 1
End If
' alte Dateien auf ZielPC löschen (u.a. *.end / *.no )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = VBSStart
' Trace32Log "0335 :: : """ & Txt, 1
Txt = Mid( Txt, InStrRev( Txt, "\" ) ) ' alles ab dem letztet "\"
' Trace32Log "0337 :: : """ & Txt, 1
Txt = Mid( Txt, 1, InStrRev( Txt, "." ) ) & "*" ' alles bis zum letzten Punkt und um "*" erweitert
' Trace32Log "0339 :: : """ & Txt, 1
Txt = ZielVerz & Txt ' alles bis zum letzten Punkt und um "*" erweitert
Trace32Log "0341 :: Dataeien sind zu löschen: """ & Txt, 1
On Error Resume Next
Tst = fso.DeleteFile( Txt ) ' : MsgBox "Gelöscht: " & Txt, , "0344 :: "
On Error Goto 0
' (Neue) Dateien auf ZielPC kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = VBSStart
Txt = Mid( Txt, 1, InStrRev( Txt, "." ) ) & "*" ' alles bis zum letzten Punkt und um ".*" erweitert
Trace32Log "0351 :: Ist zu kopieren: """ & Txt & """ nach """ & ZielVerz & "\"" (" & Tst & ")", 1
Tst = fso.CopyFile( Txt, ZielVerz & "\" )
Trace32Log "0353 :: Kopiert: """ & Txt & """ nach """ & ZielVerz & "\"" (" & Tst & ")", 1
' Skript "VBSDienst1" auf ZielPC erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 'nur' zum Start von "VBSDienst" erforderlich
ZielDatei = ZielVerz & "\" & VBSDienst1
Trace32Log "0360 :: Soll erstellt werden: """ & ZielDatei & """ " , 1
Txt = "WScript.CreateObject(""WScript.Shell"").Run """ & ZielWinDir & "\Temp\dieseyer.de\" & VBSDienst & """, , False "
' fso.OpenTextFile( VBSDienst1, 2, True ).Write( Txt ) ' für Tests, ins aktuelle Verz.
fso.OpenTextFile( ZielDatei, 2, True ).Write( Txt ) ' 2: löschen und neu erstellen
Trace32Log "0364 :: Ist erstellt: """ & ZielDatei & """ " , 1
' Skript "VBSDienst" auf ZielPC erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' existiert 'VBSStart' ".no" => WScript.Quit; 'VBSStart' wird nicht gestartet
' existiert 'VBSStart' ".end" => "1Service" entfernen
' existiert 'VBSStart' ".boot" => es folgt "Shutdown -r -f -t 180" - Reboot in 3min
' fehlt 'VBSStart' => "1Service" entfernen
' existiert 'VBSStart' ".leer" => "1Service" entfernen; Dateien löschen
' existiert 'VBSDienst' ".leer" => "1Service" entfernen; Dateien löschen
If InStr( VBSStart, "\" ) > 1 Then VBSStart = Mid( VBSStart, InStrRev( VBSStart, "\" ) + 1 ) : Trace32Log "0376 :: Aus Variable ""VBSStart"" Pfadangabe entfernt / jetzt ohne ""\"" ", 1
Txt = "Set fso = WScript.CreateObject(""Scripting.FileSystemObject"")"
Txt = Txt & vbCRLF & " Trace32Log "" "", 1 "
Txt = Txt & vbCRLF & " Trace32Log ""0380 :: Start . . . "" & WScript.ScriptFullName, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & Mid( VBSStart, 1, InStrRev( VBSStart, "." ) )
Tst = Tst & "no"
Txt = Txt & vbCRLF & "If fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0385 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Trace32Log ""0386 :: Existiert: " & Tst & """, 2 "
Txt = Txt & vbCRLF & " Trace32Log ""0387 :: WScript.Quit folgt . . . "", 1 "
Txt = Txt & vbCRLF & " WScript.Quit"
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF & " Trace32Log ""0390 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & Mid( VBSStart, 1, InStrRev( VBSStart, "." ) )
Tst = Tst & "end"
Txt = Txt & vbCRLF & "If fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0395 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Call ServiceEntfernen( ""."", """ & Dienst1 & """ ) "
Txt = Txt & vbCRLF & " Trace32Log ""0397 :: Beendet: ServiceEntfernen( """"."""", """"" & Dienst1 & """"" ) "", 1"
Txt = Txt & vbCRLF & " WScript.Quit "
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF & " Trace32Log ""0400 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & Mid( VBSStart, 1, InStrRev( VBSStart, "." ) )
Tst = Tst & "boot"
Txt = Txt & vbCRLF & "If fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0405 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Trace32Log ""0406 :: Existiert: " & Tst & """, 2 "
Txt = Txt & vbCRLF & " Trace32Log ""0407 :: Reboot wird ausgelöst . . . "", 1 "
Txt = Txt & vbCRLF & " WScript.CreateObject(""WScript.Shell"").Run ""Shutdown -r -f -t 180 -c """"Shutdown wurde von '" & Dienst1 & "' ausgelöst."", , False "
Txt = Txt & vbCRLF & " Trace32Log ""0409 :: Reboot ist angefordert . . . "", 1 "
Txt = Txt & vbCRLF & " WScript.Quit"
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF & " Trace32Log ""0412 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & VBSStart
Txt = Txt & vbCRLF & "If not fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0416 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Call ServiceEntfernen( ""."", """ & Dienst1 & """ ) "
Txt = Txt & vbCRLF & " Trace32Log ""0418 :: Beendet: ServiceEntfernen( """"."""", """"" & Dienst1 & """"" ) "", 1"
Txt = Txt & vbCRLF & " WScript.Quit "
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & " Trace32Log ""0422 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & " Trace32Log ""0424 :: Wird gestartet: " & Tst & """, 1 "
Txt = Txt & vbCRLF & "WScript.CreateObject(""WScript.Shell"").Run """ & Tst & """, , False "
Txt = Txt & vbCRLF & " Trace32Log ""0426 :: Wurde gestartet: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & " Trace32Log ""0428 :: Ende . . . "", 1 "
Txt = Txt & vbCRLF & "WScript.Quit"
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & ProzedurInTxt( "Trace32Log" )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & vbCRLF & ProzedurInTxt( "ServiceEntfernen" )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & vbCRLF
ZielDatei = ZielVerz & "\" & VBSDienst
Trace32Log "0438 :: Soll erstellt werden: """ & ZielDatei & """ " , 1
' fso.OpenTextFile( VBSDienst, 2, True ).Write( Txt ) ' für Tests, ins aktuelle Verz.
fso.OpenTextFile( ZielDatei, 2, True ).Write( Txt ) ' 2: löschen und neu erstellen
Trace32Log "0442 :: Ist erstellt: """ & ZielDatei & """ " , 1
End Sub ' ZielSkripteErstellen
'*********************************************************
Sub ServiceErstellen( PC, Dienst, Progr )
'*********************************************************
' http://msdn.microsoft.com/library/en-us/wmisdk/wmi/create_method_in_class_win32_baseservice.asp
Trace32Log "0452 :: START: Sub ServiceErstellen( """ & PC & """, """ & Dienst & """, """ & Progr & """ )", 1
Const INTERACTIVE_YES = True
Const INTERACTIVE_NOT = False
Dim objWMIService, colServices, objService
Dim Txt
' Test, ob Dienst existiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
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 & ") existiert bereits, muss also nicht erstellt werden."
Next
Set objWMIService = nothing
Set colServices = nothing
' If Len( Txt ) > 5 Then MsgBox now() & vbCRLF & Txt & " existiert bereits.", , "0471 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "0472 :: " & Txt, 1
If Len( Txt ) > 5 Then Exit Sub
' Dienst installieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Create Method of the Win32_BaseService Class": http://msdn2.microsoft.com/en-us/library/aa389386(VS.85).aspx
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\" & PC & "\root\cimv2")
Set objService = objWMIService.Get("Win32_BaseService")
Txt = objService.Create( Dienst, Dienst, Progr, 16, 0, "Automatic", INTERACTIVE_YES )
' ServiceType - 16 - 0x10 - Own Process
' ServiceType - 32 - 0x20 - Share Process
' ErrorControl - 0 - "Ignore", User is not notified.
' ErrorControl - 1 - "Normal", User is notified.
' StartMode - "Boot", Device driver started by the operating system loader. This value is valid only for driver services.
' StartMode - "System", Device driver started by the operating system initialization process. This value is valid only for driver services.
' StartMode - "Automatic", Service to be started automatically by the service control manager during system startup.
' StartMode - "Manual", Service to be started by the service control manager when a process calls the StartService method.
' StartMode - "Disabled", Service that can no longer be started.
' DesktopInteract - "True", the service can create or communicate with windows on the desktop.
' StartName - Account name under which the service runs. Depending on the service type, the account name may be in the form of DomainName\Username. The service process is logged using one of these two forms when it runs. If the account belongs to the built-in domain, .\Username can be specified. If NULL is specified, the service is logged on as the LocalSystem account. For a kernel or system-level drivers, StartName contains the driver object name (that is, \FileSystem\Rdr or \Driver\Xns) that the input and output (I/O) system uses to load the device driver. If NULL is specified, the driver runs with a default object name created by the I/O system based on the service name. Example: DWDOM\Admin.
' StartPassword - Password to the account name specified by the StartName parameter. Specify NULL if you are not changing the password. Specify an empty string if the service has no password.
' LoadOrderGroup - Group name associated with the new service. Load order groups . . . HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\ServiceGroupOrder
' LoadOrderGroupDependencies - Array of load-ordering groups that must start before this service . . .
' ServiceDependencies - Array that contains names of services that must start before this service starts . . .
' Return Codes; RC
' 0 - The request was accepted.
' 1 - The request is not supported.
' 2 - The user did not have the necessary access.
' 3 - The service cannot be stopped because other services that are running are dependent on it.
' 4 - The requested control code is not valid, or it is unacceptable to the service.
' 5 - The requested control code cannot be sent to the service because the state of the service (Win32_BaseService State property) is equal to 0, 1, or 2.
' 6 - The service has not been started.
' 7 - The service did not respond to the start request in a timely fashion.
' 8 - Interactive process.
' 9 - The directory path to the service executable file was not found.
' 10 - The service is already running.
' 11 - The database to add a new service is locked.
' 12 - A dependency on which this service relies has been removed from the system.
' 13 - The service failed to find the service needed from a dependent service.
' 14 - The service has been disabled from the system.
' 15 - The service does not have the correct authentication to run on the system.
' 16 - This service is being removed from the system.
' 17 - There is no execution thread for the service.
' 18 - There are circular dependencies when starting the service.
' 19 - There is a service running under the same name.
' 20 - There are invalid characters in the name of the service.
' 21 - Invalid parameters have been passed to the service.
' 22 - The account which this service is to run under is either invalid or lacks the permissions to run the service.
' 23 - The service exists in the database of services available from the system.
' 24 - The service is currently paused in the system.
' MsgBox now() & vbCRLF & "Der Dienst """ & Dienst & """ wurde erstellt: RC=" & Txt, , "0523 :: " & WScript.ScriptName
Trace32Log "0524 :: Der Dienst """ & Dienst & """ wurde erstellt: RC=" & Txt, 1
Set objWMIService = nothing
Set colServices = nothing
WScript.Sleep 15*1000
' Test, ob Dienst existiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
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 & ") existiert."
Next
Set objWMIService = nothing
Set colServices = nothing
' If Len( Txt ) > 5 Then MsgBox now() & vbCRLF & Txt & " existiert.", , "0541 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "0542 :: " & Txt, 1
If Len( Txt ) > 5 Then Exit Sub
Txt = "FEHLER: Der Dienst """ & Dienst & """ konnte auf """ & PC & """ nicht erstellt werden. (" & Txt & ")"
WSHShell.Popup now() & vbCRLF & Txt, 15, "0546 :: " & "= = = E N D E = = ="
Trace32Log "0547 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0549 :: " & "= = = E N D E = = ="
WScript.Quit
End Sub ' ServiceErstellen( PC, Dienst, Progr )
'*********************************************************
Sub ServiceEntfernen( PC, Dienst )
'*********************************************************
Trace32Log "0559 :: 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 "0567 :: Stopanforderung . . . ", 1
WScript.Sleep 3*1000
objService.Delete() : Trace32Log "0569 :: 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 , , "0583 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "0584 :: " & Txt, 1
If Len( Txt ) > 5 Then Exit Sub
Txt = "FEHLER: Der Dienst """ & Dienst & """ konnte nicht von """ & PC & """ entfernt werden."
WSHShell.Popup now() & vbCRLF & Txt, 15, "0588 :: " & "= = = E N D E = = ="
Trace32Log "0589 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0591 :: " & "= = = E N D E = = ="
WScript.Quit
End Sub ' ServiceEntfernen
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceStarten( PC, Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService, colServices
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
VielStat = "JA"
ServiceStarten = ""
If VielStat = "JA" Then Trace32Log " ", 1
If VielStat = "JA" Then Trace32Log "--- Start: Function ServiceStarten( """ & Dienst & """ )", 1
If VielStat = "JA" Then Trace32Log "0609 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . .", 1
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\" & PC & "\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then Trace32Log "0618 :: " & Dienst & " hat schon den richtigen Namen.", 1
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then Trace32Log "0620 :: " & Dienst & " heisst 'richtig': " & objService.Name, 1
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServiceStarten = """" & Dienst & """ existiert nicht."
Trace32Log "0625 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden.", 1
If VielStat = "JA" Then Trace32Log "0626 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" ", 1
Exit Function
End If
If VielStat = "JA" Then Trace32Log "0629 :: ==> """ & Dienst & """ soll gestartet werden. . .", 1
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStarten = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then Trace32Log "0641 :: " & ServiceStarten, 1
' "richtigen" (Dienst-) Namen starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
ServiceStarten = objService.StartService()
Next
Set objWMIService = nothing
Set colServices = Nothing
Tst = ServiceStarten ' Wenn ServiceStarten Text enthält, gibt es bei "If Tst = 14 Then" einen Fehler
If Tst = 0 Then ServiceStarten = ServiceStarten & ": Dienst erfolgreich gestartet."
If Tst = 7 Then ServiceStarten = ServiceStarten & ": ""Zeitüberschreitung (30s?) beim Startversuch."""
If Tst = 8 Then ServiceStarten = ServiceStarten & ": Für den Start einer VBS durch einen Dienst muss ""wscript.exe"" vor dem Skript stehen!"
If Tst = 10 Then ServiceStarten = ServiceStarten & ": Dienst war bereits gestartet."
If Tst = 14 Then ServiceStarten = ServiceStarten & ": Deaktivierter Dienst wurde nicht gestartet."
If VielStat = "JA" Then Trace32Log "0659 :: " & ServiceStarten, 1
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStarten = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
Trace32Log "0671 :: " & ServiceStarten, 1
If VielStat = "JA" Then Trace32Log "--- Ende: Function ServiceStarten( Dienst )", 1
End Function ' ServiceStarten( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptInfo( Ttt )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss beim Aufruf als Parameter einen PCNamen erhalten -" & vbCRLF
Txt = Txt & "z.B. aus einer CMD-Datei heraus, die nur folgende Zeile enthält:" & vbCRLF
Txt = Txt & """vbsbeimsystemstart.vbs PC001""" & vbCRLF & vbCRLF
Txt = Txt & "[Ok]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
If InStr( Ttt, " :" & ": " ) = 0 Then Txt = "FEHLER: """ & Ttt & """ " & vbCRLF & vbCRLF & Txt : Ttt = ""
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 1 )
If vbOK = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "0796 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "0800 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo( Ttt )
'*** v8.3 *** www.dieseyer.de *******************************
Sub TempHilfeHta
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "0820 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "0823 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "0824 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "0825 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, True)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta
'*** v8.4 *** www.dieseyer.de *******************************
Sub TempHilfeTxt( TxtDatei )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als Txt-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "txt"
TmpDatei = TxtDatei
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "0883 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "0886 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "0887 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "0888 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Set FileOut = fso.OpenTextFile( TmpDatei, 2, True)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run TmpDatei, , True
' fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeTxt( TxtDatei )
'*** v6.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 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("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'*** v8.4 *** www.dieseyer.de *******************************
Function RemoteWinDir( PCName )
'************************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "FEHLER: " & Tst : Exit Function
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
RemoteWinDir = objOperatingSystem.WindowsDirectory
Next
End Function ' RemoteWinDir( PCName )
'*** v8.4 *** www.dieseyer.de ****************************
Function ProzedurInTxt( ProzName )
'*********************************************************
' Übergibt (aus dem aktuellen VBS) den Inhalt einer Prozedur
ProzName = LCase( ProzName )
Dim i
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, ZeileAkt, ProzOK
ProzOK = "-OK"
Txt = "'*********************************************************"
Dim FileIn : Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
ZeileAkt = FileIn.Readline
Tst = LCase( ZeileAkt )
If ProzOK = "-OK" Then
Tyt = InStr( Tst, "function " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
Tyt = InStr( Tst, "sub " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
End If
If ProzOK = "OK" Then Txt = Txt & vbCRLF & ZeileAkt ' : MsgBox now() & vbCRLF & Txt, , "0971 :: " : i = i + 1 : If i > 10 Then WScript.Quit
If ProzOK = "OK" AND InStr( Tst, "end function" ) > 0 Then Exit Do
If ProzOK = "OK" AND InStr( Tst, "end sub" ) > 0 Then Exit Do
Loop
FileIn.Close : Set FileIn = nothing
Txt = Txt & vbCRLF & "'*********************************************************"
ProzedurInTxt = Txt ' : MsgBox now() & vbCRLF & ProzedurInTxt, , "0982 :: "
End Function ' ProzedurInTxt( ProzName )
'*** v8.4 *** www.dieseyer.de *******************************
Sub TempHilfeTxt( TxtDatei )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als Txt-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "txt"
TmpDatei = TxtDatei
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "1003 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "1006 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "1007 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "1008 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Set FileOut = fso.OpenTextFile( TmpDatei, 2, True)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run TmpDatei, , True
' fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeTxt( TxtDatei )
'*** 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 )
#########################################################################
>>> vbsbeimsystemstart.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: vbsbeimsystemstart.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' (siehe auch "wmi-VBSalsService.vbs")
'
'
' Das Skript erwartet beim Aufruf einen PCNamen und einen
' Programmnamen (mein.vbs oder deine.cmd), auf dem der
' Dienst "1Service" erstellt werden soll, der das Programm
' beim Systemstart starten wird.
' Ist der entfernte PC erreichbar und sind die erforderlichen
' Rechte vorhanden, werden auf diesem
' - der Dienst "1Service" erstellt
' - das Skript 'VBSDienst' geschrieben
' - das Programm (in Variable 'VBSStart') dorthin kopiert
' - eine vorhandene Programmname-.INI-Datei wird auch kopiert
' (Fehlt 'VBSStart' wird als Demo eine VBS-Datei erstellt,
' die sich beim Dienststart meldet.)
' Das Skript erwartet beim Aufruf zwei Parameter: einen
' PC (-Namen) auf dem der Dienst "1Service" erstellt werden
' soll und ein Programm (-Name; z.B. 'mein.vbs' oder
' 'deine.cmd'), das beim Systemstart gestartet werden soll.
' Ist der entfernte PC erreichbar und sind die erforderlichen
' Rechte vorhanden, werden auf diesem
' - der Dienst "1Service" erstellt
' - das Skript 'VBSDienst1' geschrieben
' - das Skript 'VBSDienst' geschrieben
' - das Programm (in Variable 'VBSStart') dorthin kopiert
' - vorhandene Programmname.* - Datei(en) werden kopiert
' (Fehlt 'VBSStart' wird als Demo eine VBS-Datei erstellt,
' die sich beim Dienststart meldet.)
'
' Der Dienst "1Service" starte auf dem entfernten PC bei
' jedem Systemstart (vor einer Benutzeranmeldung) das Skript
' 'VBSDienst'. Dieses prüft, ob der Dienst "1Service"
' entfernt oder ob das Programm 'VBSStart' aufgerufen werden
' soll - diese Steuerung ist in 'VBSDienst' implementiert
' und vom Vorhandensein verschiedener Dateien abhängig:
' Der Dienst "1Service" startet das Skript 'VBSDienst1' auf
' dem entfernten PC (sofort und dann) bei jedem Systemstart
' vor einer Benutzeranmeldung - 'VBSDienst1' ruft 'VBSDienst'
' auf. Dieses prüft, ob der Dienst "1Service" entfernt oder
' ob das Programm 'VBSStart' aufgerufen werden soll - diese
' Steuerung ist in 'VBSDienst' implementiert und vom
' Vorhandensein verschiedener Dateien abhängig:
'
' - es existiert 'VBSStart' mit der Dateiendung (eXtension)
' ".no" (z.B. statt ".vbs"): 'VBSStart' wird nicht
' gestartet; der "1Service" bleibt erhalten.
'
' - es existiert 'VBSStart' mit der Dateiendung ".boot":
' statt 'VBSStart' wird der PC nach 3min neu gestartet;
' der "1Service" bleibt erhalten.
'
' - es existiert 'VBSStart' mit der Dateiendung ".end" oder
' - es fehlt das Skript 'VBSStart':
' Der Dienst "1Service" wird gelöscht bzw. entfernt.
'
' Z.B. wenn 'VBSStart' seine Aufgaben erfüllt hat, löscht
' es sich selbst und beim nächsten Systemstart wird der
' Dienst "1Service" von 'VBSDienst' entfernt. Oder wenn
' 'VBSStart' seine Aufgaben erfüllt hat, schreibt 'VBSStart'
' eine dieser Dateien; beim nächsten Systemstart . . .
'
' Da das Skript 'VBSDienst1' kein richtiger Dienst sein kann,
' wird es vom Dienstmanager nach 30s beendet - mit einem
' Fehlereintrag in der Ereignisanzeige.
' Dieses Skript ist eine Erweiterung bzw. Ablösung von
' "wmi-vbsalsservice.vbs" ab.
'
'************************************************************
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
Const VBSDienst1 = "VBSdienst1.vbs" ' wird von 'Dienst1' gestartet
Const VBSDienst = "VBSdienst.vbs" ' wird von 'VBSDienst1' gestartet und startet 'VBSDienst'
Const VBSVerz = "DatenVerz" ' dieses Verz. wird auf den entfernten PC kopiert
Dim VBSStart ' das Skript / die Batch / das Programm, das vom Dienst gestartet werden soll
Dim ZielPC
Dim ZielVerz, ZielWinDir, ZielDatei, Txt, Tst
' MsgBox vbTab & "START", , "0097 :: " & WScript.ScriptName
' Parameter auswerten
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Es muss ein PCName als Parameter übergeben werden
If oArgs.Count = 0 Then
SkriptInfo( "0104 :: " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
ZielPC = UCase( oArgs.item( 0 ) )
If oArgs.Count > 1 Then VBSStart = LCase( oArgs.item( 1 ) )
If Len( ZielPC ) > 15 Then
SkriptInfo( "Der PCName ist zu lang! " ) ' Sub-Prozedur-Aufruf
WScript.Quit
End If
' 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 "0136 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "0137 :: LogDatei: " & LogDatei, 1
Trace32Log "0138 :: AktVerz: " & AktVerz, 1
Trace32Log "0139 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "0140 :: Angemeldeter User: " & WSHNet.UserName, 1
Trace32Log "0141 :: ZielPC: " & ZielPC, 1
' ZielPC erreichbar?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not WMIpingOK( ZielPC ) Then
Txt = "ZielPC """ & ZielPC & """ ist nicht erreichbar."
Trace32Log "0148 :: " & Txt, 2
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "0149 :: " & WScript.ScriptName
Trace32Log "0150 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0152 :: " & "= = = E N D E = = ="
WScript.Quit
End If
Txt = "ZielPC ist per WMI-Ping erreichbar: " & ZielPC : Trace32Log "0155 :: " & Txt, 1 : ' WSHShell.Popup now() & vbCRLF & Txt, 5, "0155 :: " & "= = = E N D E = = ="
Call VerzZielPC ' prüft Verzeichnisse und erstellt ggf. welche
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ZielSkripteErstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielDatei = "wscript.exe " & ZielWinDir & "\Temp\dieseyer.de\" & VBSDienst1
Trace32Log "0168 :: Service auf """ & ZielPC & """ erstellen", 1
Trace32Log "0169 :: Service startet """ & ZielDatei & """ ", 1
'Call ServiceEntfernen( ZielPC, Dienst1 ) : WScript.Quit ' Für Tests
Call ServiceErstellen( ZielPC, Dienst1, Zieldatei )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ServiceStarten( ZielPC, Dienst1 )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Call ServiceEntfernen( ZielPC, Dienst1 )
' wird 'eigentlich' vom entfernten PC selbst aufgerufen
' Prozedur wird in 'VBSDienst' eingefügt
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "Dienst ""1Service"" wurde installiert und gestartet auf "
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 7, "0186 :: " & WScript.ScriptName
Trace32Log "0188 :: " & Txt, 1
Trace32Log "0189 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
LogDatei = "" : Trace32Log "Abgearbeitet: """ & ZielPC & """ " , 1 ' LOG-Datei ist VBS-Name
WScript.Quit
'*********************************************************
Sub VerzZielPC()
'*********************************************************
' %WinDir% auf ZielPC ermitteln
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielWinDir = RemoteWinDir( ZielPC )
' Trace32Log "0203 :: 'ZielWinDir': " & ZielWinDir, 1
If InStr( ZielWinDir, "FEHLER:" ) = 1 Then
Txt = "'ZielWinDir' auf """ & ZielPC & """ kann nicht ermittelt werden: " & ZielWinDir
Trace32Log "0206 :: " & Txt, 2
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "0207 :: " & WScript.ScriptName
Trace32Log "0209 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0211 :: " & "= = = E N D E = = ="
WScript.Quit
End If
Trace32Log "0214 :: 'ZielWinDir' auf """ & ZielPC & """ ist " & ZielWinDir, 1
' Mit ZielPC verbinden
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = ZielWinDir
'' Txt = "%WinDIR% des ZielPC ist: """ & ZielVerz & "\"" "
'' Trace32Log "0221 :: " & Txt, 1
'' Txt = Mid( ZielVerz, 3 )
ZielVerz = "\\" & ZielPC & "\" & Mid( ZielVerz, 1, 1 ) & "$" & Mid( ZielVerz, 3 )
If fso.FolderExists( ZielVerz ) Then
Else
Txt = "Verzeichnis ist nicht erreichbar: """ & ZielVerz & "\"" "
Trace32Log "0228 :: " & Txt, 2
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "0229 :: " & WScript.ScriptName
Trace32Log "0230 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0232 :: " & "= = = E N D E = = ="
WScript.Quit
End If
Trace32Log "0235 :: Auf """ & ZielPC & """ erreichbar: " & ZielVerz, 1
' Auf ZielPC %WinDir%\Temp erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = ZielVerz & "\Temp"
If fso.FolderExists( ZielVerz ) Then
Trace32Log "0242 :: Verzeichnis existiert: """ & ZielVerz & "\"" " , 1
Else
Trace32Log "0244 :: Verzeichnis wird angelegt: " & ZielVerz & "\"" " , 1
On Error Resume Next
err.Clear
fso.CreateFolder ZielVerz
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
Txt = "Verzeichnis kann nicht angelegt werden: """ & ZielVerz & "\"" "
Trace32Log "0252 :: " & Txt, 2
Trace32Log "0253 :: " & Tst, 3
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & Tst & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "0254 :: " & WScript.ScriptName
Trace32Log "0255 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0257 :: " & "= = = E N D E = = ="
WScript.Quit
End If
End If
Trace32Log "0261 :: Auf """ & ZielPC & """ erreichbar: " & ZielVerz, 1
' Auf ZielPC %WinDir%\Temp\dieseyer.de erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = ZielVerz & "\dieseyer.de"
If fso.FolderExists( ZielVerz ) Then
Trace32Log "0268 :: Verzeichnis existiert: " & ZielVerz & "\"" " , 1
Else
Trace32Log "0270 :: Verzeichnis wird angelegt: " & ZielVerz & "\"" " , 1
On Error Resume Next
err.Clear
fso.CreateFolder ZielVerz
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
Txt = "Verzeichnis kann nicht angelegt werden: """ & ZielVerz & "\"" "
Trace32Log "0278 :: " & Txt, 2
Trace32Log "0279 :: " & Tst, 3
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & Tst & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "0280 :: " & WScript.ScriptName
Trace32Log "0281 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0283 :: " & "= = = E N D E = = ="
WScript.Quit
End If
End If
Trace32Log "0287 :: Auf """ & ZielPC & """ erreichbar: " & ZielVerz & "\"" ", 1
' Schreibtest auf ZielPC
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
err.Clear
fso.OpenTextFile( ZielVerz & "\dummy.tmp", 8, True ).WriteLine ( "TEST" )
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
Txt = "In Verzeichnis kann nicht geschrieben werden: """ & ZielVerz & "\"" "
Trace32Log "0299 :: " & Txt, 2
Trace32Log "0300 :: " & Tst, 3
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & Tst & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "0301 :: " & WScript.ScriptName
Trace32Log "0302 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0304 :: " & "= = = E N D E = = ="
WScript.Quit
End If
fso.DeleteFile ZielVerz & "\dummy.tmp", True
' Schreibtest auf ZielPC - Info-Datei erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = ZielVerz & "\" & Dienst1 & ".txt" ' : MsgBox Tst, , "0312 :: "
Call TempHilfeTxt( Tst )
End Sub ' VerzZielPC()
'*********************************************************
Sub ZielSkripteErstellen
'*********************************************************
Dim Tst, Txt, Tyt, VBSStartName
' Skript / Programm "VBSStart" auf ZielPC bereitstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( VBSStart ) = 0 Then
' wenn kein zu startendes Programm als Parameter an
' dieses Skipt übergeben wurde: VBS für Tests erstellen
VBSStart = "VBSStart.vbs" ' als Beispiel
' ZielDatei = ZielVerz & "\" & VBSStart
Trace32Log "0330 :: Soll erstellt werden: """ & ZielDatei & """ " , 1
Txt = "MsgBox now() & vbTab & "". . . . hier bin ich:"" & vbCRLF & vbCRLF & WScript.ScriptFullName, , WScript.ScriptName"
' fso.OpenTextFile( VBSDienst, 2, True ).Write( Txt ) ' für Tests, ins aktuelle Verz.
fso.OpenTextFile( ZielDatei, 2, True ).Write( Txt ) ' 2: löschen und neu erstellen
Trace32Log "0334 :: Ist erstellt: """ & ZielDatei & """ " , 1
End If
VBSStartName = VBSStart
Trace32Log "0338 :: : """ & VBSStartName & """ ", 1
If InStrRev( VBSStartName, "\" ) > 0 Then VBSStartName = Mid( VBSStartName, InStrRev( VBSStartName, "\" ) + 1 ) ' alles nch dem letzten "\"
Trace32Log "0340 :: : """ & VBSStartName & """ ", 1
VBSStartName = Mid( VBSStartName, 1, InStrRev( VBSStartName, "." ) - 1 ) ' alles vor dem letzten Punkt
Trace32Log "0342 :: VBSStartName: """ & VBSStartName & """ ", 1
' alte Dateien auf ZielPC löschen (u.a. *.end / *.no )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ZielVerz & "\" & VBSStartName & ".*"
Trace32Log "0348 :: (Alte) Dateien sind zu löschen: """ & Txt, 1
On Error Resume Next
Tst = fso.DeleteFile( Txt ) ' : MsgBox "Gelöscht: " & Txt, , "0350 :: "
On Error Goto 0
' (Neue) Dateien auf ZielPC kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = VBSStart
Txt = Mid( Txt, 1, InStrRev( Txt, "." ) ) & "*" ' alles bis zum letzten Punkt und um ".*" erweitert
Tst = ZielWinDir & "\Temp\dieseyer.de\" & Mid( VBSStart, 1, InStrRev( VBSStart, "." ) )
Trace32Log "0358 :: Ist zu kopieren: """ & Txt & """ nach """ & ZielVerz & "\"" (" & Tst & ")", 1
Trace32Log "0359 :: Ist zu kopieren: """ & Txt & """ nach """ & ZielVerz & "\"" ", 1
Tst = fso.CopyFile( Txt, ZielVerz & "\" )
Trace32Log "0361 :: Kopiert: """ & Txt & """ nach """ & ZielVerz & "\"" (" & Tst & ")", 1
' Skript "VBSDienst1" auf ZielPC erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 'nur' zum Start von "VBSDienst" erforderlich
ZielDatei = ZielVerz & "\" & VBSDienst1
Trace32Log "0368 :: Soll erstellt werden: """ & ZielDatei & """ " , 1
Txt = "WScript.CreateObject(""WScript.Shell"").Run """ & ZielWinDir & "\Temp\dieseyer.de\" & VBSDienst & """, , False "
' fso.OpenTextFile( VBSDienst1, 2, True ).Write( Txt ) ' für Tests, ins aktuelle Verz.
fso.OpenTextFile( ZielDatei, 2, True ).Write( Txt ) ' 2: löschen und neu erstellen
Trace32Log "0372 :: Ist erstellt: """ & ZielDatei & """ " , 1
' Skript "VBSDienst" auf ZielPC erstellen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' existiert 'VBSStart' ".no" => WScript.Quit; 'VBSStart' wird nicht gestartet
' existiert 'VBSStart' ".end" => "1Service" entfernen
' existiert 'VBSStart' ".boot" => es folgt "Shutdown -r -f -t 180" - Reboot in 3min
' fehlt 'VBSStart' => "1Service" entfernen
' existiert 'VBSStart' ".leer" => "1Service" entfernen; Dateien löschen
' existiert 'VBSDienst' ".leer" => "1Service" entfernen; Dateien löschen
If InStr( VBSStart, "\" ) > 1 Then VBSStart = Mid( VBSStart, InStrRev( VBSStart, "\" ) + 1 ) : Trace32Log "0384 :: Aus Variable ""VBSStart"" Pfadangabe entfernt / jetzt ohne ""\"" ", 1
Txt = "Set fso = WScript.CreateObject(""Scripting.FileSystemObject"")"
Txt = Txt & vbCRLF & " Trace32Log "" "", 1 "
Txt = Txt & vbCRLF & " Trace32Log ""0388 :: Start . . . "" & WScript.ScriptFullName, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & Mid( VBSStart, 1, InStrRev( VBSStart, "." ) )
Tst = ZielWinDir & "\Temp\dieseyer.de\" & VBSStartName
Tst = Tst & ".no"
Txt = Txt & vbCRLF & "If fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0394 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Trace32Log ""0395 :: Existiert: " & Tst & """, 2 "
Txt = Txt & vbCRLF & " Trace32Log ""0396 :: WScript.Quit folgt . . . "", 1 "
Txt = Txt & vbCRLF & " WScript.Quit"
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF & " Trace32Log ""0399 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & VBSStartName
Tst = Tst & ".end"
Txt = Txt & vbCRLF & "If fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0404 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Call ServiceEntfernen( ""."", """ & Dienst1 & """ ) "
Txt = Txt & vbCRLF & " Trace32Log ""0406 :: Beendet: ServiceEntfernen( """"."""", """"" & Dienst1 & """"" ) "", 1"
Txt = Txt & vbCRLF & " WScript.Quit "
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF & " Trace32Log ""0409 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & VBSStartName
Tst = Tst & ".boot"
Txt = Txt & vbCRLF & "If fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0414 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Trace32Log ""0415 :: Existiert: " & Tst & """, 2 "
Txt = Txt & vbCRLF & " Trace32Log ""0416 :: Reboot wird ausgelöst . . . "", 1 "
Txt = Txt & vbCRLF & " WScript.CreateObject(""WScript.Shell"").Run ""Shutdown -r -f -t 180 -c """"Shutdown wurde von '" & Dienst1 & "' ausgelöst."", , False "
Txt = Txt & vbCRLF & " Trace32Log ""0418 :: Reboot ist angefordert . . . "", 1 "
Txt = Txt & vbCRLF & " WScript.Quit"
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF & " Trace32Log ""0421 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Tst = ZielWinDir & "\Temp\dieseyer.de\" & VBSStart
Tst = ZielWinDir & "\Temp\dieseyer.de\" & Mid( VBSStart, InStrRev( VBSStart, "\" ) + 1 )
Txt = Txt & vbCRLF & "If not fso.FileExists( """ & Tst & """ ) Then"
Txt = Txt & vbCRLF & " Trace32Log ""0426 :: Fehlt: " & Tst & """, 1 "
Txt = Txt & vbCRLF & " Call ServiceEntfernen( ""."", """ & Dienst1 & """ ) "
Txt = Txt & vbCRLF & " Trace32Log ""0428 :: Beendet: ServiceEntfernen( """"."""", """"" & Dienst1 & """"" ) "", 1"
Txt = Txt & vbCRLF & " WScript.Quit "
Txt = Txt & vbCRLF & "End If"
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & " Trace32Log ""0432 :: Existiert: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & " Trace32Log ""0434 :: Wird gestartet: " & Tst & """, 1 "
Txt = Txt & vbCRLF & "WScript.CreateObject(""WScript.Shell"").Run """ & Tst & """, , False "
Txt = Txt & vbCRLF & " Trace32Log ""0436 :: Wurde gestartet: " & Tst & """, 1 "
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & " Trace32Log ""0438 :: Ende . . . "", 1 "
Txt = Txt & vbCRLF & "WScript.Quit"
Txt = Txt & vbCRLF
Txt = Txt & vbCRLF & ProzedurInTxt( "Trace32Log" )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & vbCRLF & ProzedurInTxt( "ServiceEntfernen" )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & vbCRLF
ZielDatei = ZielVerz & "\" & VBSDienst
Trace32Log "0448 :: Soll erstellt werden: """ & ZielDatei & """ " , 1
' fso.OpenTextFile( VBSDienst, 2, True ).Write( Txt ) ' für Tests, ins aktuelle Verz.
fso.OpenTextFile( ZielDatei, 2, True ).Write( Txt ) ' 2: löschen und neu erstellen
Trace32Log "0452 :: Ist erstellt: """ & ZielDatei & """ " , 1
End Sub ' ZielSkripteErstellen
'*********************************************************
Sub ServiceErstellen( PC, Dienst, Progr )
'*********************************************************
' http://msdn.microsoft.com/library/en-us/wmisdk/wmi/create_method_in_class_win32_baseservice.asp
Trace32Log "0463 :: START: Sub ServiceErstellen( """ & PC & """, """ & Dienst & """, """ & Progr & """ )", 1
Const INTERACTIVE_YES = True
Const INTERACTIVE_NOT = False
Dim objWMIService, colServices, objService
Dim Txt
' Test, ob Dienst existiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
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 & ") existiert bereits, muss also nicht erstellt werden."
Next
Set objWMIService = nothing
Set colServices = nothing
' If Len( Txt ) > 5 Then MsgBox now() & vbCRLF & Txt & " existiert bereits.", , "0482 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "0483 :: " & Txt, 1
If Len( Txt ) > 5 Then Exit Sub
' Dienst installieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' "Create Method of the Win32_BaseService Class": http://msdn2.microsoft.com/en-us/library/aa389386(VS.85).aspx
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\" & PC & "\root\cimv2")
Set objService = objWMIService.Get("Win32_BaseService")
Txt = objService.Create( Dienst, Dienst, Progr, 16, 0, "Automatic", INTERACTIVE_YES )
' ServiceType - 16 - 0x10 - Own Process
' ServiceType - 32 - 0x20 - Share Process
' ErrorControl - 0 - "Ignore", User is not notified.
' ErrorControl - 1 - "Normal", User is notified.
' StartMode - "Boot", Device driver started by the operating system loader. This value is valid only for driver services.
' StartMode - "System", Device driver started by the operating system initialization process. This value is valid only for driver services.
' StartMode - "Automatic", Service to be started automatically by the service control manager during system startup.
' StartMode - "Manual", Service to be started by the service control manager when a process calls the StartService method.
' StartMode - "Disabled", Service that can no longer be started.
' DesktopInteract - "True", the service can create or communicate with windows on the desktop.
' StartName - Account name under which the service runs. Depending on the service type, the account name may be in the form of DomainName\Username. The service process is logged using one of these two forms when it runs. If the account belongs to the built-in domain, .\Username can be specified. If NULL is specified, the service is logged on as the LocalSystem account. For a kernel or system-level drivers, StartName contains the driver object name (that is, \FileSystem\Rdr or \Driver\Xns) that the input and output (I/O) system uses to load the device driver. If NULL is specified, the driver runs with a default object name created by the I/O system based on the service name. Example: DWDOM\Admin.
' StartPassword - Password to the account name specified by the StartName parameter. Specify NULL if you are not changing the password. Specify an empty string if the service has no password.
' LoadOrderGroup - Group name associated with the new service. Load order groups . . . HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\ServiceGroupOrder
' LoadOrderGroupDependencies - Array of load-ordering groups that must start before this service . . .
' ServiceDependencies - Array that contains names of services that must start before this service starts . . .
' Return Codes; RC
' 0 - The request was accepted.
' 1 - The request is not supported.
' 2 - The user did not have the necessary access.
' 3 - The service cannot be stopped because other services that are running are dependent on it.
' 4 - The requested control code is not valid, or it is unacceptable to the service.
' 5 - The requested control code cannot be sent to the service because the state of the service (Win32_BaseService State property) is equal to 0, 1, or 2.
' 6 - The service has not been started.
' 7 - The service did not respond to the start request in a timely fashion.
' 8 - Interactive process.
' 9 - The directory path to the service executable file was not found.
' 10 - The service is already running.
' 11 - The database to add a new service is locked.
' 12 - A dependency on which this service relies has been removed from the system.
' 13 - The service failed to find the service needed from a dependent service.
' 14 - The service has been disabled from the system.
' 15 - The service does not have the correct authentication to run on the system.
' 16 - This service is being removed from the system.
' 17 - There is no execution thread for the service.
' 18 - There are circular dependencies when starting the service.
' 19 - There is a service running under the same name.
' 20 - There are invalid characters in the name of the service.
' 21 - Invalid parameters have been passed to the service.
' 22 - The account which this service is to run under is either invalid or lacks the permissions to run the service.
' 23 - The service exists in the database of services available from the system.
' 24 - The service is currently paused in the system.
' MsgBox now() & vbCRLF & "Der Dienst """ & Dienst & """ wurde erstellt: RC=" & Txt, , "0534 :: " & WScript.ScriptName
Trace32Log "0535 :: Der Dienst """ & Dienst & """ wurde erstellt: RC=" & Txt, 1
Set objWMIService = nothing
Set colServices = nothing
WScript.Sleep 15*1000
' Test, ob Dienst existiert
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ""
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 & ") existiert."
Next
Set objWMIService = nothing
Set colServices = nothing
' If Len( Txt ) > 5 Then MsgBox now() & vbCRLF & Txt & " existiert.", , "0552 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "0553 :: " & Txt, 1
If Len( Txt ) > 5 Then Exit Sub
Txt = "FEHLER: Der Dienst """ & Dienst & """ konnte auf """ & PC & """ nicht erstellt werden. (" & Txt & ")"
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "0557 :: " & WScript.ScriptName
Trace32Log "0558 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0560 :: " & "= = = E N D E = = ="
WScript.Quit
End Sub ' ServiceErstellen( PC, Dienst, Progr )
'*********************************************************
Sub ServiceEntfernen( PC, Dienst )
'*********************************************************
Trace32Log "0570 :: 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 "0578 :: Stopanforderung . . . ", 1
WScript.Sleep 3*1000
objService.Delete() : Trace32Log "0580 :: 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 , , "0594 :: " & WScript.ScriptName
If Len( Txt ) > 5 Then Trace32Log "0595 :: " & 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, "0599 :: " & WScript.ScriptName
Trace32Log "0600 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "0602 :: " & "= = = E N D E = = ="
WScript.Quit
End Sub ' ServiceEntfernen
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceStarten( PC, Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService, colServices
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
VielStat = "JA"
ServiceStarten = ""
If VielStat = "JA" Then Trace32Log " ", 1
If VielStat = "JA" Then Trace32Log "--- Start: Function ServiceStarten( """ & Dienst & """ )", 1
If VielStat = "JA" Then Trace32Log "0620 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . .", 1
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\" & PC & "\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then Trace32Log "0629 :: " & Dienst & " hat schon den richtigen Namen.", 1
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then Trace32Log "0631 :: " & Dienst & " heisst 'richtig': " & objService.Name, 1
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServiceStarten = """" & Dienst & """ existiert nicht."
Trace32Log "0636 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden.", 1
If VielStat = "JA" Then Trace32Log "0637 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" ", 1
Exit Function
End If
If VielStat = "JA" Then Trace32Log "0640 :: ==> """ & Dienst & """ soll gestartet werden. . .", 1
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStarten = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then Trace32Log "0652 :: " & ServiceStarten, 1
' "richtigen" (Dienst-) Namen starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
ServiceStarten = objService.StartService()
Next
Set objWMIService = nothing
Set colServices = Nothing
Tst = ServiceStarten ' Wenn ServiceStarten Text enthält, gibt es bei "If Tst = 14 Then" einen Fehler
If Tst = 0 Then ServiceStarten = ServiceStarten & ": Dienst erfolgreich gestartet."
If Tst = 7 Then ServiceStarten = ServiceStarten & ": ""Zeitüberschreitung (30s?) beim Startversuch."""
If Tst = 8 Then ServiceStarten = ServiceStarten & ": Für den Start einer VBS durch einen Dienst muss ""wscript.exe"" vor dem Skript stehen!"
If Tst = 10 Then ServiceStarten = ServiceStarten & ": Dienst war bereits gestartet."
If Tst = 14 Then ServiceStarten = ServiceStarten & ": Deaktivierter Dienst wurde nicht gestartet."
If VielStat = "JA" Then Trace32Log "0670 :: " & ServiceStarten, 1
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStarten = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
Trace32Log "0682 :: " & ServiceStarten, 1
If VielStat = "JA" Then Trace32Log "--- Ende: Function ServiceStarten( Dienst )", 1
End Function ' ServiceStarten( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Sub SkriptInfo( Ttt )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst
Txt = ""
Txt = Txt & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Txt = Txt & "Das Skript muss beim Aufruf als Parameter einen PCNamen erhalten -" & vbCRLF
Txt = Txt & "z.B. aus einer CMD-Datei heraus, die nur folgende Zeile enthält:" & vbCRLF
Txt = Txt & """vbsbeimsystemstart.vbs PC001""" & vbCRLF & vbCRLF
Txt = Txt & "[Ok]" & vbTab & vbTab & "Weitere Infos (als Hilfe) ansehen." & vbCRLF
Txt = Txt & "[Abbrechen]" & vbTab & "Bei ""Aaaaaaaangst""." & vbCRLF
If InStr( Ttt, " :" & ": " ) = 0 Then Txt = "FEHLER: """ & Ttt & """ " & vbCRLF & vbCRLF & Txt : Ttt = ""
Txt = WSHShell.Popup (Txt , 30, Ttt & WScript.ScriptName, 4096 + 512 + 32 + 1 )
If vbOK = Txt Then
Call TempHilfeHta ' Sub-Prozedur - Aufruf
WSHShell.Popup WScript.ScriptFullName & vbCRLF & vbCRLF & "hat nichts getan und beendet sich jetzt.", 13, "0808 :: " & WScript.ScriptName, 48 + 4096
WScript.Quit
End If
WSHShell.Popup " . . . dann eben nicht!", 10, "0812 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096
WScript.Quit
End Sub ' SkriptInfo( Ttt )
'*** v8.3 *** www.dieseyer.de *******************************
Sub TempHilfeHta
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als htm-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "htm"
' TmpDatei als hta-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "hta"
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "0833 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "0836 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "0837 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "0838 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Tst = "<head>"
Tst = Tst & vbCRLF & "<title>Info zu """ & WScript.Scriptname & """</title>"
Tst = Tst & vbCRLF & "< HTA:APPLICATION ID=""" & WScript.Scriptname & """ "
' Mein Virenscanner meckert, wenn sich im VBS in "< HT" kein Leerzeichen befindet
Tst = Replace( Tst, "< HT", "<HT" )
Tst = Tst & vbCRLF & "SCROLL=""yes"" "
Tst = Tst & vbCRLF & "SHOWINTASKBAR=""yes"" "
Tst = Tst & vbCRLF & "NAVIGABLE=""yes"" "
Tst = Tst & vbCRLF & "APPLICATIONNAME=""" & WScript.Scriptname & """ >"
Tst = Tst & vbCRLF & "</head><body>"
Tst = Tst & vbCRLF & "</head><body><pre>" ' <pre> sorgt dafür, dass KEINE Proportionalschrift verwendet wird
Txt = Tst & vbCRLF & Txt & vbCRLF & "</pre></head><body>"
Set FileOut = fso.OpenTextFile( TmpDatei, 2, True)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run "mshta.exe " & TmpDatei
' WSHShell.Run """" & TmpDatei & """"
WSHShell.Run TmpDatei, , True
' Bei der Anzeige einer HTM(L)-Datei im Browser kann nicht auf
' das Ende der Anwendung / Anzeige gewartet werden - also darf
' auch die Datei, die gerade angezeigt wird, nicht gelöscht
' werden.
' Bei einer HTA-Datei ist das anders . . .
fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeHta
'*** v8.4 *** www.dieseyer.de *******************************
Sub TempHilfeTxt( TxtDatei )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als Txt-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "txt"
TmpDatei = TxtDatei
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "0897 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "0900 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "0901 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "0902 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Set FileOut = fso.OpenTextFile( TmpDatei, 2, True)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run TmpDatei, , True
' fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeTxt( TxtDatei )
'*** v6.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 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("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteWinDir( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %WINDIR% == %SYSTEMROOT%; häufig C:\Windows
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
Dim WindowsDirectory, SystemDirectory
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-Sys " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysDir " & Tst : Exit Function
WindowsDirectory = objOperatingSystem.WindowsDirectory
SystemDirectory = objOperatingSystem.SystemDirectory
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
If WindowsDirectory = "" Then
SystemDirectory = UCase( SystemDirectory )
If InStr( SystemDirectory, "\SYSTEM32" ) Then WindowsDirectory = Replace( SystemDirectory, "\SYSTEM32", "" )
End If
RemoteWinDir = WindowsDirectory
' RemoteWinDir = "%..root%: " & RemoteWinDir
End Function ' RemoteWinDir( PCName )
'*** v8.4 *** www.dieseyer.de ****************************
Function ProzedurInTxt( ProzName )
'*********************************************************
' Übergibt (aus dem aktuellen VBS) den Inhalt einer Prozedur
ProzName = LCase( ProzName )
Dim i
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, ZeileAkt, ProzOK
ProzOK = "-OK"
Txt = "'*********************************************************"
Dim FileIn : Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
ZeileAkt = FileIn.Readline
Tst = LCase( ZeileAkt )
If ProzOK = "-OK" Then
Tyt = InStr( Tst, "function " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
Tyt = InStr( Tst, "sub " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
End If
If ProzOK = "OK" Then Txt = Txt & vbCRLF & ZeileAkt ' : MsgBox now() & vbCRLF & Txt, , "0989 :: " : i = i + 1 : If i > 10 Then WScript.Quit
If ProzOK = "OK" AND InStr( Tst, "end function" ) > 0 Then Exit Do
If ProzOK = "OK" AND InStr( Tst, "end sub" ) > 0 Then Exit Do
Loop
FileIn.Close : Set FileIn = nothing
Txt = Txt & vbCRLF & "'*********************************************************"
ProzedurInTxt = Txt ' : MsgBox now() & vbCRLF & ProzedurInTxt, , "1000 :: "
End Function ' ProzedurInTxt( ProzName )
'*** v8.4 *** www.dieseyer.de *******************************
Sub TempHilfeTxt( TxtDatei )
'************************************************************
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim TmpDatei : TmpDatei = fso.GetSpecialFolder( 2 ) & "\" & fso.GetTempName
Dim FileOut, FileIn, Txt, Tst
' TmpDatei als Txt-Datei
TmpDatei = Mid( TmpDatei, 1, InStrRev( TmpDatei, "." ) ) & "txt"
TmpDatei = TxtDatei
' MsgBox vbTab & "TmpDatei: " & vbCRLF & vbCRLF & TmpDatei, , "1019 :: " & WScript.ScriptName
Txt = ""
' Txt = Txt & vbTab & "1022 :: """ & WScript.ScriptFullName & """, letzte " & vbCRLF
' Txt = Txt & vbTab & "1023 :: " & "Änderung vom " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & ", enthält" & vbCRLF
' Txt = Txt & vbTab & "1024 :: " & "folgende Infos:" & vbCRLF & vbCRLF
Set FileIn = fso.OpenTextFile( WScript.ScriptFullName, 1 )
Do While Not ( FileIn.atEndOfStream )
Tst = FileIn.Readline
Txt = Txt & Mid( Tst, 2 ) & vbCRLF ' entfernt das führende ' (Hochkomma)
If InStr( Tst, "'**********" ) = 1 Then Exit Do
If InStr( Tst, "' **********" ) = 1 Then Exit Do
Loop
Set FileOut = fso.OpenTextFile( TmpDatei, 2, True)
FileOut.Write( Txt )
FileOut.Close
Set FileOut = Nothing
' WSHShell.Run TmpDatei, , True
' fso.DeleteFile TmpDatei, True
End Sub ' TempHilfeTxt( TxtDatei )
'*** 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 )
#########################################################################
>>> vbseditor+.vbs <<<
'*** v10.1 *** www.dieseyer.de *****************************
'
' Datei: vbseditor+.vbs
' Autor: W. Schmelz
' Auf: www.dieseyer.de
'
' Vor der Ausführung das VBS als
' "V-b-sEditor+.v-b-s" speichern!
'
'***********************************************************
'********************************************************
'* *
'* Editoren gibt es viele! - Mich reizte es aber, mir *
'* selbst einen mit Mitteln des H-t-a zu schreiben !! *
'* Im Explorer ist eine beliebige Datei wählbar! Er - *
'* möglicht wird dieses für "Txt", "V-b-s", "H-t-a" ! *
'* Es wird hier mit eingebundener H-t-a gearbeitet,- *
'* diese gibt die Zeilen der betrachteten Datei aus ! *
'* - Oder Datei auf dieses Programm ziehen und fallen *
'* lassen! Die Datei wird in nummerierten Zeilen ab- *
'* schnittweise angezeigt. Dabei ist außer "Abbruch" *
'* auch ein "Zurück" und natürlich "Weiter" möglich , *
'* sowohl für die angezeigten Zeilenblöcke als auch *
'* für die darin in einem Textfeld bearbeitbar ange - *
'* zeigte Zeile! Diese kann man dann abändern und die *
'* Änderung in der betreffenden " Datei " speichern! *
'* Ferner können eine beliebige oder eine neue, noch *
'* völlig leere Datei im Explorer aufgerufen werden ! *
'* Es können die Objekte Fso, Wss oder der Inhalt der *
'* Ablage eingefügt und auf Wunsch widerrufen werden! *
'* Es kann auch ein bestimmtes "Wort" gesucht werden! *
'* Außerdem ist ein Wort durch ein anderes ersetzbar! *
'* Nachteil ist, dass nur eine Zeile immer bearbeitet *
'* werden kann, diese kann man aber schnell wechseln! *
'* Der Editor arbeitet wie andere, er druckt sogar!!! *
'* *
'********************************************************
'CopyRight: W. Schmelz, 16.12.2009
Zeit = Timer
' Objekte u.a. werden für das Programm bereit gestellt :
'*******************************************************
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Arg=Wscript.Arguments
Datei0=WScript.ScriptFullName
UV=VbCR&VbCR
' Voreinstellung einiger wichtiger Variablen :
'*********************************************
Start=""
Ende=""
Neu="0"
Anfang="1"
FrageKorr="1"
Plus="0"
Wort="0" 'Bestimmtes Wort suchen in der " Datei "
Block="0" 'Bei Blockaufrufen 1. Zeile als Textzeile
Dazu="0"
Suche="0"
Ersatz="0" 'Wort ggf. durch Ersatzwort ersetzen
Korr="0" 'Zeilenzahl-Korrektur bei überlangen Zeilen
Folge="0" 'Folgebefehl bei Zeilenspeicherung
Dim Ende, Doppel, Zeile(), Datei, AktVerz, Summe, Schnitt
Dim Liste(), Eins, Stelle, Summ(), Schluss, Datei0, DateiZ
Dim Wert, Frage, Wunsch, Start, Zeilen(), Noch, Nr, DateiN
Dim UrZeile(), FragZeil, Zeil(), NochA, Neu, Wrt(), Plus
Dim ZeilPlus(), FrageKorr, Block, Dazu, NochB, Zeit, Zei()
Dim Wort, Hier, Numb, Stamm, Wt(), SuchDat, Tg, TempVerz
Dim WortN, Ersatz
'**********************************************************
' Das temporäre Arbeitsverzeichnis wird vorweg festgelegt :
' Das temp. Verzeichnis des Users verweigerte den Zugriff ?
' Vermutlich eine Abwehr evtl. " schädlicher " Programme !?
'**********************************************************
OrtP="C:\Programme\Schmelz.W"
OrtPP=OrtP&"\"&"V"&"b"&"s"&"Editor"
If not Fso.FolderExists(OrtP) then Fso.CreateFolder OrtP, true
'"true" soll evtl. Schreibschutz aushebeln, auch für Weiteres!
If not Fso.FolderExists(OrtPP) then Fso.CreateFolder(OrtPP)
TempVerz=OrtPP&"\"
Titel=" VbsEditor"
'Aufgesetzte Datei oder zurück Gemeldetes wird ermittelt:
'********************************************************
For i=0 to Arg.Count-1 'Arg.Count:Zahl aufgesetzter Arg.
Datei=Arg.Item(0)
' oder : For i=1 to Arg.Count / Datei=Arg.Item(0)
If i=1 then Start=Arg.Item(1)
If i=2 then FragZeil=Arg.Item(2)
' Leerzeilen / Leerstellen nicht möglich, s.u.
If i=3 then Frage=Arg.Item(3)
If i=4 then Neu=Arg.Item(4)
If i=5 then Plus=Arg.Item(5)
'Zu suchendes Wort / evtl. Folgebefehl nach Speichern
If i=6 then Wort=Arg.Item(6)
Next
' Arg.Item(6) ist zu suchendes Wort oder Folgebefehl ?
'*****************************************************
If Left(Wort,3)="&%;" then
Wort=Right(Wort,Len(Wort)-3)
Folge="0"
else
Folge=Wort
Wort="0"
End If
' Wort ggf. in Wort und Ersatzwort aufspalten :
'**********************************************
Lang=Len(Wort)
If (Folge="0" and Len(Wort)>1) then
For i=1 to Lang
If Mid(Wort,i,3 )="###" then
WortN=Right(Wort,Len(Wort)-i+1-3)
Wort=Left(Wort,i-1)
Ersatz="1"
End If
Next
End If
'Datei auf alte Form bringen, mit Leerstellen !
'**********************************************
For i=1 to Len(Datei)
ReDim Preserve Wt(i)
Wt(i)=Mid(Datei,i,1)
If Wt(i)=Chr(30) then Wt(i)=" "
Next
Datei=Join(Wt,"")
'Verlangtes Wort suchen und dessen Fundstellen ausgeben,
'oder das Wort mit einem gewünschten neuem Wort ersetzen
'*******************************************************
If Wort<>"0" then Suchen
'*******************************************************
Sub Suchen
Titel=" Wort in Datei suchen ! "
' Wort auf alte Form bringen, mit Leerstellen !
'**********************************************
For i=1 to Len(Wort)
ReDim Preserve Wt(i)
Wt(i)=Mid(Wort,i,1)
If Wt(i)=Chr(30) then Wt(i)=" "
Next
Wort=Join(Wt,"")
Wort=LCase(Wort)
'Vorliegende Datei öffnen und auslesen:
'**************************************
Set File=Fso.OpenTextFile(Datei,1,true)
i=1
Do until File.AtEndOfStream
ReDim Preserve Zei(i)
Zei(i)=File.ReadLine
i=i+1
Loop
Ende=i-1
File.Close
Set File=Nothing
' Suche des Wortes in den Zeilen der Datei :
'*******************************************
Hier=""
Numb="0" 'Zahl der Fundstellen
For i=1 to Ende
k=1
Do until k>Len(Zei(i))-Len(Wort)+1
If LCase(Mid(Zei(i),k,Len(Wort)))=Wort then
If Ersatz="1" then
Zei(i)=Left(Zei(i),k-1)&WortN&Right(Zei(i),Len(Zei(i))-(Len(Wort)+k-1))
End If
If Len(Hier)>0 then Hier=Hier&"|"&i
If Hier="" then Hier=i
Numb=Numb+1 'Wie oft "Wort" gefunden ?
End If
k=k+1
Loop
Next
' Falls garnichts in der Datei zu finden gewesen war :
'*****************************************************
If Hier="" then MsgBox UV&VbCR&"Das Wort "" "&_
Wort&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:Exit Sub 'Abbruch !
' Ggf. eine neue Datei mit dem Ersatzwort schreiben :
'****************************************************
If Ersatz="1" then
Stamm=Fso.GetParentFolderName(Datei)
DateiNeu=Stamm&"\"&Fso.GetBaseName(Datei)&"-Neu."&Right(Datei,3)
Set File=Fso.OpenTextFile(DateiNeu,2,true)
For i=1 to Ende
File.WriteLine(Zei(i))
Next
File.Close
Set File=Nothing
MsgBox UV&VbTab&"Eine neue Datei :"&UV&" "&DateiNeu&_
" "&UV&VbTab&"wurde geschrieben!"
End If
' Wenn nur Wort gesucht wird, die Fundstellen aufschreiben :
'***********************************************************
If Ersatz="0" then
'Die Zeilen mit Nr. versehen:
'****************************
For i=1 to Ende
Zei(i)=i&VbTab&Zei(i)
Next
'Die Aufsplittung der Fundorte in Ort(i), beginnend mit Ort(0)!
'**************************************************************
Ort=Split(Hier,"|")
'Ausgabedatei festlegen und gefundene Zeilen mit Nr. schreiben:
'**************************************************************
Stamm=Fso.GetParentFolderName(Datei)
DateiN=Fso.GetBaseName(Datei)&"-Such.txt"
AktVerz=Replace(Datei,Fso.GetFileName(Datei),"")
DateiN=AktVerz&DateiN
Set File=Fso.OpenTextFile(DateiN,2,true)
File.WriteLine(" ")
File.WriteLine(" Das Wort "" "&Wort&" "" steht in diesen Zeilen :")
File.WriteLine("***************************************************")
i=0
Do until i=Numb 'Beginn mit i=0 !
File.WriteLine(" ")
File.WriteLine(Zei(Ort(i)))
i=i+1
Loop
File.Close
Set File=Nothing
'Bei Sucherfolg Datei mit Zeilen-Nr. am Ende zeigen :
'****************************************************
End If
End Sub
'****************************************************
' Bei völligem Neustart des Programmes :
'***************************************
If (Arg.Count=0 or Arg.Count=1) then
Set Data=Fso.GetFolder(Left(TempVerz,Len(TempVerz)-1)).Files
For each i in Data
Fso.DeleteFile(i) ' Temporäres Verzeichnis leeren!
Next
End If
If Frage=Start then Block="1" 'Bei Blockwechsel
If Start="" then Start="1"
'******************************************************
' *
' Falls aber überhaupt garkeine Datei hier aufgesetzt *
' wurde, kann man diese jetzt im "Explorer" browsen , *
' oder nach eigenem Wunsch beliebig, neu festlegen !! *
' Da Set IE aber viel Zeit kostet, erst hier setzen ! *
' *
'******************************************************
If Datei="" then
Ask=InputBox(UV&UV&_
"Man kann eine Datei auf das Programm aufsetzen,"&UV&_
"oder im Explorer die gewünschte Datei auswählen,"&UV&_
"oder einen Ordner aussuchen für eine neue Datei !"&UV&_
"Im 1. Fall abbrechen und Drag & Drop anwenden,"&UV&_
"Dateiauswahl erfolgt mit "" 1 "", neue Datei mit "&_
""" 2""!"&UV&UV,Titel,"1")
If Ask="" then WScript.Quit ' Abbruch, wenn "Cancel"
If Ask="1" then
' Eine gewünschte Datei im Explorer aussuchen :
'**********************************************
Set IE=CreateObject("InternetExplorer.Application")
IE.Navigate("About:Blank")
IE.Document.Write"<HTML><BODY>"&_
"<INPUT ID=""Files"" Type=""File""></BODY></HTML>"
IE.Height="0" 'Muss sein, damit IE verborgen!
IE.Width="0"
IE.Visible=True
With IE.Document.All.Files
.Click
Datei= .Value
End With
IE.Quit
Set IE=Nothing
Suche="1"
If Datei="" then WScript.Quit
End If
If Ask="2" then
' Eine gewünschte, neue Datei im Explorer festlegen :
'****************************************************
Set ObF=CreateObject("Shell.Application"). _
BrowseForFolder(0,Befehl,BrowseInfo,17)
'3. Stelle: 16 für Anzeige des ausgesuchten Ordners
'4. Stelle: 17 für Arbeitsplatz, 0 wäre Desktop
On Error Resume Next 'Evtl. Fehler werden ignoriert!
Pfad=ObF.Self.Path
Set All=Nothing
If Err.Number="0" then AktVerz=Pfad
On Error GoTo 0 'Ignorieren der Fehler aufheben!
If Pfad="" then WScript.Quit
Datei=InputBox(UV&UV&VbCr&"Bitte ergänzen Sie im aus"&_
"gesuchten Ordner den "&UV&_
"Namen der von Ihnen gewünschten neuen Datei !"&UV&_
UV,Titel,Pfad&"\... .vbs, txt oder h-t-a")
If Datei = "" then WScript.Quit
'Eine Nachfrage, wenn diese Datei bereits vorhanden ist:
'*******************************************************
If Fso.FileExists(Datei) then
Ask=MsgBox(UV&UV&"Die Datei existiert bereits ! "&_
"Fortsetzen ? "&UV&_
"Sie würde sonst einfach überschrieben !"&UV&_
UV,VbCritical+VbYesNo)
If Ask="7" then WScript.Quit ' Bei Abbruch!
End If
' Diese neue Datei wird nun erstellt :
'*************************************
Set Data=Fso.CreateTextFile(Datei)
Data.WriteLine("")
Data.WriteLine("")
Data.Close
Suche="1"
End If
End If
'Falls die aufgesetzte, bestimmte Datei ungeeignet ist:
'******************************************************
Endg=LCase(Right(Datei,3))
If not (Endg="txt" or Endg="vbs" or Endg="hta") then
MsgBox UV&VbCR&_
"Die aufgesetzte Datei ist ungeeignet ! "&_
UV&VbCR,VbCritical,Titel:WScript.Quit
End If
Titel=""""&Datei&""""
' Momentanes Datum, heutiger Wochentag, Dateidaten !
'***************************************************
Tag=Weekday(Date) 'Den Wochentag bestimmen !
Select Case Tag
Case "1" Tg="Sonntag"
Case "2" Tg="Montag"
Case "3" Tg="Dienstag"
Case "4" Tg="Mittwoch"
Case "5" Tg="Donnerstag"
Case "6" Tg="Freitag"
Case "7" Tg="Samstag"
End Select
Set File=Fso.GetFile(Datei)
Gross=File.Size 'Größe der Datei in Byte
Schaffen=File.DateCreated 'Datum der "Erstellung"
Aenderg=File.DateLastModified 'Datum letzter Änderung
Zugriff=File.DateLastAccessed 'Datum letzten Zugriffes
'***************************************************
'* *
'* Falls nicht die Rückwärtsdatei schon existiert *
'* oder die aufgesetzte Datei verändert worden ist *
'* diese aufgesetzte Datei zeilenweise auslesen ! *
'* Die Zeilenlänge aber auf 100 Zeichen begrenzen, *
'* indem der Rest in Zusatzzeilen darunter kommt ! *
'* *
'***************************************************
'Hilfsdatei für die Kehrzeilen wird DateiR benannt:
'***************************************************
DateiR=TempVerz&Fso.GetBaseName(Datei)&_
"-Rueck."&Endg
If not Fso.FileExists (DateiR) or Neu="1" then
'############################################## s.u.
Set File=Fso.OpenTextFile(Datei,1,true)
NochA="0" 'Zahl aller Zusatzzeilen
i=1
Do until File.AtEndOfStream
ReDim Preserve Zeile(i)
ReDim Preserve UrZeile(i)
Zeile(i)=File.ReadLine 'Zeilen von "Datei" lesen
UrZeile(i-NochA)=Zeile(i) 'Urzeilen zurücklegen
' Alle Nr. auf gleiche Länge bringen:
'************************************
Nr=i-NochA
If Len(Nr)=1 then Nr="000"&Nr
If Len(Nr)=2 then Nr="00"&Nr
If Len(Nr)=3 then Nr="0"&Nr
Zeile(i)=Nr&" "&Zeile(i)
Noch="0" ' Zusatzzeilen dieser Zeile(i)
'Falls Zeile zu lang ist, in Zusatzzeilen aufteilen:
'***************************************************
If Len(Zeile(i))>100 then ' <<<<<<<<<<<<<< s.u.
Rest=Zeile(i)
Zeile(i)=Left(Zeile(i),100)
Rest=Right(Rest,Len(Rest)-100) 'Zeilenrest
If Rest<>"" then
k=i
Do
k=k+1
ReDim Preserve Zeile(k)
If Len(Rest)<=100 then
Zeile(k)=" "&Rest
Rest=""
else
Zeile(k)=" "&Left(Rest,100)
Rest=Right(Rest,Len(Rest)-100) 'Zeilenrest
End If
Noch=1+Noch
Loop until Rest=""
End If
End If ' <<<<<<<<<<<<<< s.o.
NochA=NochA+Noch 'Zahl bisheriger Zusatzzeilen
i=i+1+Noch 'Zahl aller bisheriger Zeilen
Loop
Ende=i-1 'Die Zahl aller dieser Zeilen
File.Close
Set File=Nothing
'******************************************************
' *
' Beim Neustart die Textzeile in die 1. Zeile setzen: *
' *
'******************************************************
If not Fso.FileExists(DateiR) then
FragZeil=UrZeile(1)
' In dieser "FragZeil" die " " " mit "" " ersetzen :
'*******************************************************
i=1
Do until Mid(FragZeil,i,1)=""
If Mid(FragZeil,i,1)="""" then
FragZeil=Left(FragZeil,i-1)&"""&_
Right(FragZeil,Len(FragZeil)-i)
i=i+1
End If
i=i+1
Loop
End If
'Zusatzzeilen hier definieren, aber erst später festlegen:
'*********************************************************
For i=1 to Ende
ReDim Preserve ZeilPlus(i)
ZeilPlus(i)="0"
Next
' Die Anführungsstriche " in den Zeilen sind zu verdoppeln,
' ist zum Schreiben der " H-t-a " - Datei unbedingt nötig !
'**********************************************************
For i=1 to Ende
Doppel="0" 'Zahl der Verdoppelungen
k=1
Do until k=Len(Zeile(i))+1+Doppel
If Mid (Zeile(i),k,1)="""" then
Zeile(i)=Left(Zeile(i),k)&""""&_
Right(Zeile(i),Len(Zeile(i))-k)
Doppel=1+Doppel
k=k+1
End If
k=k+1
Loop
Next
'***********************************************************
'* *
'* Da Hta - Programmteile wie Input - Fenster und Radio - *
'* Button - statt nur angezeigt - ausgeführt werden, ergab *
'* sich Chaos. So werden alle Zeilen rückwärts geschrieben *
'* an "DateiZ" übergeben. Da werden sie wieder umgekehrt!! *
'* *
'***********************************************************
For i=1 to Ende
ReDim Preserve Zeilen(i)
Zeilen(i)=Zeile(i)
Zeile(i)=""
Next
For i=1 to Ende
For k=1 to Len(Zeilen(i))
Zeile(i)=Zeile(i)&Mid(Zeilen(i), _
Len(Zeilen(i))+1-k,1)
Next
Next
'***********************************************************
' *
' Die DateiR schreiben ( die rückwärts geschriebene aufge- *
' setzte Datei ) damit diese nicht laufend umzukehren ist! *
' *
'***********************************************************
On Error Resume Next
' Bei H-t-a - Dateien traten teilweise Probleme auf !?
Set Abcd=Fso.CreateTextFile(DateiR,true)
For n=1 to Ende
Abcd.WriteLine(Zeile(n))
Next
Abcd.Close
Set Abcd=Nothing
On Error GoTo 0
End If
'############################# s.o.
'**************************************************************
' Folg. Abschnitt wird nur bei wiederholten Aufrufen gestartet:
'**************************************************************
If (Fso.FileExists(DateiR) and not Start="") then
'Diese rückwärts geschriebene Datei: " DateiR " jetzt auslesen:
'**************************************************************
Set Data=Fso.OpenTextFile(DateiR,1,true)
NochA="0"
Frage=CInt(Frage) ' Gefragte Zeile rückwärts schreiben, suchen!
If Len(Frage)="1" then Frage="000"&Frage
If Len(Frage)="2" then Frage="00"&Frage
If Len(Frage)="3" then Frage="0"&Frage
FrageRev=Right(Frage,1)&Mid(Frage,3,1)&Mid(Frage,2,1)&Left(Frage,1)
k="0"
i=1
Do until Data.AtEndOfStream
ReDim Preserve Zeile(i)
ReDim Preserve Zeil(i)
ReDim Preserve ZeilPlus(i)
Zeile(i)=Data.ReadLine 'Zeilen von "DateiR" lesen
If Right(Zeile(i),4)=FrageRev then FrageKorr=i
'Beim Blockwechsel : " Frage " hat keine Zeilenverschiebung:
'***********************************************************
If CInt(Start)=i then NochB=NochA
If (CInt(Start)=i-1 and Block="1" and Right(Zeile(i-1),7) _
<>";061#& " and i>=2) then Frage=Frage-NochB
If (CInt(Start)=i-1 and Block="1" and Right(Zeile(i-1),7) _
=";061#& " and i>=2) then
Frage=Frage-NochB+1
Dazu="2"
If Right(Zeile(i),7)=";061#& " then
Frage=1+Frage
Dazu="4"
End If
End If
'Eine Korrektur der Zeilenzahl bei " überlangen " Zeilen:
'********************************************************
If Right(Zeile(i),7)=";061#& " then NochA=1+NochA
ZeilPlus(i)=NochA ' Zahl der Zusatzzeilen
Zeil(i)=Zeile(i)
i=i+1
Loop
Ende=i-1
Data.Close
Set Data = Nothing
' Beim Blockwechsel die Textzeile an den Anfang setzen :
'*******************************************************
If Block="1" then FrageKorr=CInt(Start)+CInt(Dazu)
' Falls eine neue Zeile für das Textfeld bestimmt wurde ,
' dann diese rückwärts geschriebene Zeile auch umkehren :
'********************************************************
If FragZeil="&&&###;;;" then 'Merkmal für neue Textzeile
' Die Zusatzzeilen sind nun wieder aneinander zu setzen,
' dabei sind auch die Nummern der Zeilen zu korrigieren !
'********************************************************
Doppel="0"
For k=1 to Ende
If Right(Zeile(k),35)=";061#& ;061#& ;061#& ;061#& ;061#& " then
Zeil(k-1-Doppel)=Left(Zeile(k),Len _
(Zeile(k))-35)&Zeil(k-1-Doppel)
Doppel=1+Doppel
else
Zeil(k-Doppel)=Zeile(k)
End If
Next
'Die neue Textzeile rückwärts, d.h. richtig schreiben:
'*****************************************************
FragZeil=Left(Zeil(Frage),Len(Zeil(Frage))-10)
For k=1 to Len(FragZeil)
FragZei=FragZei&Mid(FragZeil,Len(FragZeil)+1-k,1)
Next
FragZeil=FragZei
' In der neuen Zeile die " mit " " " ersetzen :
'**************************************************
i=1
Do until Mid(FragZeil,i,1)=""
If Mid(FragZeil,i,2)="""""" then
FragZeil=Left(FragZeil,i-1)&"""&_
Right(FragZeil,Len(FragZeil)-i-1)
i=i+1
End If
i=i+1
Loop
End If
End If
'****************************************************************
' *
' Die Leerstellen in "FragZeil" müssen unbedingt mit " " *
' ersetzt werden, sonst ist FragZeil bei "Weiter" oder "Zurück" *
' nicht übermittelbar, denn im Übermittelten sind " " verboten! *
' *
'****************************************************************
If FragZeil<>"" then
i=1
Do until Mid(FragZeil,i,1)=""
If Mid(FragZeil,i,1)=" " then
FragZeil=Left(FragZeil,i-1)&" "&_
Right(FragZeil,Len(FragZeil)-i )
End If
i=i+1
Loop
End If
' Bei ihrem Aufruf vor die Textzeile immer 10 Zeilen setzen :
'************************************************************
If Plus="1" then Start=FrageKorr-10
If Start<1 then Start="1"
'##############################################################
'# #
'# #
'# H-t-a-Datei zur Anzeige des gewünschten Blockes schreiben: #
'# #
'# #
'##############################################################
DateiZ=TempVerz&"DateiZeigen."&"h"&"t"&"a"
DateiOld=Fso.GetFileName(Datei)
DateiOld=Left(DateiOld,Len(DateiOld)-4)&"Old"&Right(DateiOld,4)
DateiOld=TempVerz&DateiOld 'Sicherungsdatei1
DateiNeu=Fso.GetFileName(Datei)
DateiNeu=Left(DateiNeu,Len(DateiNeu)-4)&"Neu"&Right(DateiNeu,4)
DateiNeu=TempVerz&DateiNeu 'Sicherungsdatei2
'Vorige Version von DateiZ löschen, wenn noch vorhanden:
'*******************************************************
On Error Resume Next
If Fso.FileExists(DateiZ) then Fso.DeleteFile(DateiZ)
On Error GoTo 0
' Datei "DateiZ" ist jedes Mal völlig neu zu schreiben :
'*******************************************************
If not Fso.FileExists(DateiZ) then
'Nur bei Neustart die Frage links oben als 0001 setzen :
'*******************************************************
If (Arg.Count="1" or Suche="1") then Frage="0001"
Set F=Fso.CreateTextFile(DateiZ)
F.WriteLine(" <Html> ")
F.WriteLine(" <Head> ")
F.Write(" <Hta:Application Id=""OHTA"" Border=""Yes""")
F.WriteLine(" InnerBorder=""Yes"" Scroll=""No""> ")
F.WriteLine(" <Style Type=""Text/Css""> ")
F.Write(" TD{Font-Size:12Pt;Color:Black; ")
F.WriteLine(" Font-Style:Bold;Font-Family:Arial} ")
F.Write(" Input{Font-Size:11pt;Color:Black; ")
F.WriteLine(" Font-Style:Bold;Font-Family:Arial} ")
F.WriteLine(" </Style> ")
F.WriteLine(" <Script Language=""VBScript""> ")
F.WriteLine(" Set Wss=CreateObject(""Wscript.Shell"") ")
F.WriteLine(" Set Fso=CreateObject(""Scripting.FileSystemObject"") ")
F.WriteLine(" Dim Start, Ende, XYZ, UV,Datei1, Datei2,DateiZ,Txt() ")
F.WriteLine(" Dim Zahl, Neues, Frage, Anders, Wrt(), Stoppen, Plus ")
F.WriteLine(" Dim Nichts, FrageKorr, Reihe(), LeerZ, Zeile(),Datei ")
F.WriteLine(" Dim DateiOld, Anzahl, NeuD, DateiNeu, Nein,Schluss,Fso")
F.WriteLine(" Dim Tg, Bis, NochA, Aenderg, Gross, Test, Verschd,Flg")
F.WriteLine(" Dim TempVerz, Oben, Unten, Befehl, Folge, No, Spch,Wss")
F.WriteLine(" UV=VbCR&VbCR ")
F.WriteLine(" Plus=""0"" ")
F.WriteLine(" Verschd=""0"" ")
F.WriteLine(" NeuD=""0"" ")
F.WriteLine(" Flg=""0"" ")
F.WriteLine(" Stoppen=""0"" ")
F.WriteLine(" Folge="""&Folge&""" ")
F.WriteLine(" If Folge<>""0"" then Flg=""1"" ")
F.WriteLine(" XYZ="" "" ")
F.WriteLine(" Datei="""""""&Datei&""""""" ") 'Sonderzeichen?
F.WriteLine(" Datei0="""""""&Datei0&""""""" ")
F.WriteLine(" DateiR="""""""&DateiR&""""""" ")
F.WriteLine(" DateiOld="""""""&DateiOld&""""""" ")
F.WriteLine(" DateiNeu="""""""&DateiNeu&""""""" ")
' Inhalt der angezeigten Textzeile rückwärts schreiben :
'*******************************************************
FragZeiln=FragZeil
FragZeil=""
For k=1 to Len(FragZeiln)
FragZeil=FragZeil&Mid(FragZeiln,Len(FragZeiln)+1-k,1)
Next
F.WriteLine(" FragZeil="""&FragZeil&""" ")
F.WriteLine(" TempVerz="""&Left(TempVerz,Len(TempVerz)-1)&""" ")
F.WriteLine(" DateiZ=TempVerz&""\DateiZeigen.""&""h""&""t""&""a"" ")
F.WriteLine(" Start="""&Start&""" ")
F.WriteLine(" Anfang="""&Anfang&""" ")
F.WriteLine(" Anders=""0"" ")
F.WriteLine(" Ende="""&Ende&""" ")
F.WriteLine(" NochA="""&NochA&""" ")
F.WriteLine(" Frage="""&Frage&""" ")
F.WriteLine(" FrageKorr="""&FrageKorr&""" ")
F.WriteLine(" Zeit1="""&Zeit1&""" ")
F.WriteLine(" Tg="""&Tg&""" ")
F.WriteLine(" Gross="""&Gross&""" ")
F.WriteLine(" Aenderg="""&Aenderg&""" ")
F.WriteLine(" Window.ResizeTo 1000,730 ")
F.WriteLine(" Window.MoveTo 0,0 ")
' Evtl. Folgebefehl nach Speichern schreiben :
'*********************************************
If Folge<>"0" then
F.WriteLine( " "&Folge )
F.WriteLine( " Folge=""0"" " )
End If
Folge="0" ' Folgebefehl zurück setzen
' Es folgen jetzt die sämtlichen Sub - Prgramme :
'§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Beginn ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Start)=""1"" then Exit Sub ") 'Abbruch!
F.WriteLine(" ")
F.WriteLine("Befehl=""Beginn"" ")' Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" If CInt(Stoppen)=""1"" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Start=""1"" ") ' An den Beginn gehen !
F.WriteLine(" Frage=""15"" ")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Zurueck ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Start)=""1"" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Befehl=""Zurueck"" ")'Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" If CInt(Stoppen)=""1"" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Start)<>""1"" then ")
F.WriteLine(" Start=Start-30 ")
F.WriteLine(" else ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" Frage=Start ") 'Textzeile an den Anfang setzen
F.WriteLine(" If CInt(Frage)<1 then Frage=""1"" ")
F.WriteLine(" If CInt(Start)<1 then Start=""1"" ") 'Notbremse
F.WriteLine(" ")
F.WriteLine(" Ruf ") 'Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Weiter ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Start)+29>=CInt(Ende) then Exit Sub")'Abbruch!
F.WriteLine(" ")
F.WriteLine(" Befehl=""Weiter"" ") 'Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" If CInt(Stoppen)=""1"" then Exit Sub ")
F.WriteLine(" If CInt(Start)+30<CInt(Ende) then ")
F.WriteLine(" Start=Start+30 ")
F.WriteLine(" else ")
F.WriteLine(" Start=Start ") 'Textzeile an Anfang
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" Frage=Start ")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Grenze ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Start)+29>=CInt(Ende) then Exit Sub")'Abbruch!
F.WriteLine(" " )
F.WriteLine(" Befehl=""Grenze"" ")' Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" If CInt(Stoppen )=""1"" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Start=CInt(Ende)-17 ")
F.WriteLine(" Frage=CInt(Ende)-CInt(NochA) ")'Letzte Zeile rufen!
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" " )
F.WriteLine(" Sub Oeffnen ")
F.WriteLine(" ")
F.WriteLine(" Set IE=CreateObject(""InternetExplorer.Application"") ")
F.WriteLine(" IE.Navigate(""About:Blank"") ")
F.Write(" IE.Document.Write ""<HTML><BODY><INPUT ID= ")
F.WriteLine(" """"Files"""" Type=""""File""""></BODY></HTML>"" ")
F.WriteLine(" IE.Height=""0"" 'Muss sein, damit IE verborgen! ")
F.WriteLine(" IE.Width=""0"" ")
F.WriteLine(" IE.Visible=True ")
F.WriteLine(" ")
F.WriteLine(" With IE.Document.All.Files ")
F.WriteLine(" .Click ")
F.WriteLine(" DatN= .Value ")
F.WriteLine(" End With ")
F.WriteLine(" ")
F.WriteLine(" IE.Quit ")
F.WriteLine(" Set IE=Nothing ")
F.WriteLine(" ")
F.WriteLine(" If DatN="""" then Exit Sub ") 'Bei Abbruch !
F.WriteLine(" Wss.Run ""Notepad """"""&DatN&"""""" "" ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" " )
F.WriteLine(" Sub DatNeu ")
F.WriteLine(" " )
F.WriteLine(" Nein=""0"" ")
F.WriteLine(" NeuD=""1"" ")
F.WriteLine(" Speichern ") 'Jetzigen Zustand speichern !
F.WriteLine(" If Nein=""1"" then Exit Sub ")
F.WriteLine(" " )
F.WriteLine(" DateiNeu=TempVerz&""\DatNeu.txt"" ")
F.WriteLine(" ")
F.WriteLine(" Set Data=Fso.CreateTextFile(DateiNeu) ")
F.WriteLine(" Data.WriteLine("""") ")
F.WriteLine(" Data.WriteLine("""") ")
F.WriteLine(" Data.Close ")
F.WriteLine(" Set Data=Nothing ")
F.WriteLine(" ")
F.WriteLine(" Start=""1"" ")
F.WriteLine(" Wss.Run Datei0&"" ""&DateiNeu&"" ""&Start ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub NeuZeile ")
F.WriteLine(" ")
F.WriteLine(" Befehl="""" ") ' Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" ")
F.WriteLine(" Frage=CInt(Document.All.ZeilNr.Value) ")
F.WriteLine(" ")
F.WriteLine(" 'Den jetzigen Zustand dieser Datei sichern: ")
F.WriteLine(" '****************************************** ")
F.Write(" If Left(Datei,1)="""""""" then ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2) ")
F.Write(" If Left(DateiOld,1)="""""""" then ")
F.WriteLine(" DateiOld=Mid(DateiOld,2,Len(DateiOld)-2) ")
F.WriteLine(" Fso.CopyFile Datei,DateiOld ")
F.WriteLine(" ")
F.WriteLine(" 'Eine Leerzeile soll jetzt eingefügt werden: ")
F.WriteLine(" '******************************************* ")
F.WriteLine(" ReDim Preserve Reihe(Frage+1) ")
F.WriteLine(" Reihe(Frage+1)="""" ")
F.WriteLine(" Anzahl=""1"" ")
F.WriteLine(" LeerZ=""1"" ")
F.WriteLine(" ")
F.WriteLine(" Schreib ' Änderungen schreiben !")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Ram ")
F.WriteLine(" ")
F.WriteLine(" Frage=CInt(Document.All.ZeilNr.Value) ")
F.WriteLine(" ")
F.WriteLine(" Befehl="""" ") ' Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" ")
F.WriteLine(" 'Jetzigen Zustand dieser Datei sichern: ")
F.WriteLine(" '************************************** ")
F.Write(" If Left(Datei,1)="""""""" then ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2) ")
F.Write(" If Left(DateiOld,1)="""""""" then ")
F.WriteLine(" DateiOld=Mid(DateiOld,2,Len(DateiOld)-2) ")
F.WriteLine(" Fso.CopyFile Datei,DateiOld ")
F.WriteLine(" ")
F.WriteLine("'Einen ausgelagerten Text aus dem Clipboard holen: ")
F.WriteLine("'************************************************* ")
F.WriteLine(" On Error Resume Next ' Fehlermeldungen unterdrücken ")
F.WriteLine(" Set Obj=CreateObject(""InternetExplorer.Application"") ")
F.WriteLine(" Obj.Navigate(""About:Blank"") 'Leere Seite verbergen! ")
F.Write(" Lesen=Obj.Document.ParentWindow." )
F.WriteLine(" ClipBoardData.GetData(""Text"") " )
F.WriteLine(" Obj.Quit 'IE schließen ! ")
F.WriteLine(" Set Obj=Nothing ")
F.WriteLine(" ")
F.WriteLine(" 'Inhalt des Clipboard zeilenweise auslesen: ")
F.WriteLine(" '****************************************** ")
F.WriteLine(" Anzahl=""1"" ")
F.WriteLine(" If Len(Lesen)>=2then ")
F.WriteLine(" For i=1 to Len(Lesen)-2 ")
F.WriteLine(" If Mid(Lesen,i,2)=Chr(13)&Chr(10) then Anzahl=1+Anzahl ")
F.WriteLine(" Next ")
F.WriteLine(" else ")
F.WriteLine(" MsgBox VbCR&"" Der Textspeicher ist leer ! "" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" " )
F.WriteLine(" Reih=Split(Lesen,Chr(13)&Chr(10)) 'Beginn bei 0! " )
F.WriteLine(" For i=1 to Anzahl " )
F.WriteLine(" ReDim Preserve Reihen(i) ")
F.WriteLine(" Reihen(i)=Reih(i-1) ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" 'Bei Kopie aus diesem Editor die Zahlen entfernen: ")
F.WriteLine(" '************************************************* ")
F.Write(" If (Asc(Mid(Reihen(1),1,1))>47 and ")
F.Write(" Asc(Mid(Reihen(1),1,1))<58 and ")
F.Write(" Asc(Mid(Reihen(1),2,1))>47 and ")
F.Write(" Asc(Mid(Reihen(1),2,1))<58 and ")
F.Write(" Asc(Mid(Reihen(1),3,1))>47 and ")
F.Write(" Asc(Mid(Reihen(1),3,1))<58 and ")
F.Write(" Asc(Mid(Reihen(1),4,1))>47 and ")
F.Write(" Asc(Mid(Reihen(1),4,1))<58 and ")
F.WriteLine(" Mid(Reihen(1),5,1)="" "") then ")
F.WriteLine(" For i=1 to Anzahl ")
F.WriteLine(" Reihen(i)= Right(Reihen(i),Len(Reihen(i))-5) ")
F.WriteLine(" Next ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" 'Reihe(Frage+1)-Reihe(Frage+Anzahl) festlegen: ")
F.WriteLine(" '********************************************* ")
F.WriteLine(" For i=1 to Anzahl ")
F.WriteLine(" ReDim Preserve Reihe(i+Frage) ")
F.WriteLine(" Reihe(i+Frage)=Reihen(i) ")
F.WriteLine(" Next ")
F.WriteLine(" On Error GoTo 0 'Fehlermeldung wieder einschalten ")
F.WriteLine(" " )
F.WriteLine(" Schreib ' Änderungen in Datei schreiben! ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Objkt ")
F.WriteLine(" ")
F.WriteLine(" Frage=CInt(Document.All.ZeilNr.Value) ")
F.WriteLine(" ")
F.WriteLine(" Befehl="""" ") ' Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" ")
F.WriteLine(" If Right(Frage,1)=""X"" then ")
F.WriteLine(" MsgBox UV&""Links oben steht keine Nummer !""&_ ")
F.WriteLine(" "" ""&UV,VbCritical ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" 'Jetzigen Zustand dieser Datei sichern: ")
F.WriteLine(" '************************************** ")
F.Write(" If Left(Datei,1)="""""""" then ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2) ")
F.Write(" If Left(DateiOld,1)="""""""" then ")
F.WriteLine(" DateiOld=Mid(DateiOld,2,Len(DateiOld)-2 ) ")
F.WriteLine(" Fso.CopyFile(Datei),(DateiOld) ")
F.WriteLine(" ")
F.WriteLine(" 'Objekte oder Programm - Teile einfügen : ")
F.WriteLine(" '**************************************** ")
F.WriteLine(" 'Reihe(Frage+1) bis Reihe(Frage+15) festlegen: ")
F.WriteLine(" For i=1 to 15 ")
F.WriteLine(" ReDim Preserve Reihe(Frage+i) ")
F.WriteLine(" Next ")
F.WriteLine(" Ask=InputBox(UV&""Welches Objekt oder Teil - Programm sol""&_ ")
F.WriteLine(" ""l nach""&VbCR&"""""" Nr. """" eingefügt werden?""&UV&VbCR&_ ")
F.WriteLine(" ""1 = Fso und Wss""&UV&""2 = Arg ( Drag & Drop )""&UV&_")
F.WriteLine(" ""3 = Ordner auswählen""&UV&""4 = Datei auswählen""&_ ")
F.WriteLine(" UV&""5 = Datei aufrufen und Teile mit Strg + C in""&VbCR&_ ")
F.WriteLine(" "" Zwischenspeicher nehmen""&UV,"" Objektauswahl"")")
F.WriteLine(" If Ask="""" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Select Case Ask ")
F.WriteLine(" Case ""1"" ")
F.WriteLine(" Anzahl=""2"" ")
F.Write(" Reihe(Frage+1)=""Set Fso=WScript.CreateObject ")
F.WriteLine(" (""""Scripting.FileSystemObject"""")"" ")
F.Write(" Reihe(Frage+2)=""Set Wss=WScript.CreateObject ")
F.WriteLine(" (""""WScript.Shell"""")"" ")
F.WriteLine(" ")
F.WriteLine(" Case ""2"" ")
F.WriteLine(" Anzahl=""4"" ")
F.WriteLine(" Reihe(Frage+1)=""Set Arg=Wscript.Arguments"" ")
F.WriteLine(" Reihe(Frage+2)=""If Arg.Count>0 then Datei=Arg(0)"" ")
F.Write(" Reihe(Frage+3)=""If Datei="""""""" then MsgBox UV&")
F.WriteLine("VbCR&"""" Bitte Datei""""&_"" ")
F.Write(" Reihe(Frage+4)="""""" aufsetzen! """"")
F.WriteLine("&UV&VbCR:WScript.Quit"" ")
F.WriteLine(" ")
F.WriteLine(" Case ""3"" ")
F.WriteLine(" Anzahl=""8"" ")
F.Write(" Reihe(Frage+1)=""Set Shl=CreateObject ")
F.WriteLine(" (""""Shell.Application"""")"" ")
F.Write(" Reihe(Frage+2)=""Set ObF=Shl.BrowseForFolder ")
F.WriteLine(" (0,StrPrompt,BrowseInfo,Root)"" ")
F.WriteLine(" Reihe(Frage+3)=""On Error Resume Next"" ")
F.WriteLine(" Reihe(Frage+4)=""Err.Clear"" ")
F.WriteLine(" Reihe(Frage+5)=""Pfad=ObF.Self.Path"" ")
F.WriteLine(" Reihe(Frage+6)=""If Err.Number>0 then WScript.Quit"" ")
F.WriteLine(" Reihe(Frage+7)=""Set All=Nothing"" ")
F.WriteLine(" Reihe(Frage+8)=""On Error GoTo 0'Ignorierung weg !"" ")
F.WriteLine(" ")
F.WriteLine(" Case ""4"" ")
F.WriteLine(" Anzahl=""13"" ")
F.Write(" Reihe(Frage+1)=""Set IE=CreateObject ")
F.WriteLine(" (""""InternetExplorer.Application"""")"" ")
F.WriteLine(" Reihe(Frage+2)=""IE.Navigate(""""About:Blank"""")"" ")
F.WriteLine(" Reihe(Frage+3)=""IE.Document.Write""""<HTML>""""&_"" ")
F.Write(" Reihe(Frage+4)="" """"<BODY><INPUT ID=""""""""")
F.WriteLine(" Files"""""""" Type=""""""""File""""""""></BODY></HTML>""""""")
F.Write(" Reihe(Frage+5)=""IE.Height=""""0"""" ")
F.WriteLine(" 'Muss sein, damit IE verborgen!"" ")
F.WriteLine(" Reihe(Frage+6)=""IE.Width=""""0"""""" ")
F.WriteLine(" Reihe(Frage+7)=""IE.Visible=True"" ")
F.WriteLine(" Reihe(Frage+8)=""With IE.Document.All.Files"" ")
F.WriteLine(" Reihe(Frage+9)="" .Click"" ")
F.WriteLine(" Reihe(Frage+10)=""Datei= .Value"" ")
F.WriteLine(" Reihe(Frage+11)=""End With"" ")
F.WriteLine(" Reihe(Frage+12)=""IE.Quit"" ")
F.WriteLine(" Reihe(Frage+13)=""Set IE=Nothing"" ")
F.WriteLine(" ")
F.WriteLine(" Case ""5"" ")
F.WriteLine(" Oeffnen ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Case else ")
F.WriteLine(" MsgBox UV&"" Ungeeignete Eingabe! ""&UV ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End Select ")
F.WriteLine(" ")
F.WriteLine(" Schreib ' Änderungen in Datei schreiben ! ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Druckn ")
F.WriteLine( " " )
F.WriteLine( " ' ""Datei"" öffnen, drucken, schließen :" )
F.WriteLine( " '***************************************" )
F.WriteLine( " Lang=Len(Fso.GetFileName(Datei))" )
F.WriteLine( " Programm=""Notepad.exe"" " )
F.WriteLine( " Wss.Run Programm&"" ""&Datei" )
F.Write( " Ask = Wss.Popup (UV&""Ist der Drucker bereit ? ""& " )
F.WriteLine( " UV,5,,VbInformation+VbOkCancel+VbSystemModal) ")
F.WriteLine(" If Ask=""1"" then ")
F.WriteLine( " Wss.Sendkeys ""^{p}"" 'Strg+P? P ergibt Fehler!?" )
F.WriteLine( " Wss.Sendkeys ""{Enter}""" )
F.Write( " Wss.Popup UV&""Ist der Drucker fertig ? ""& " )
F.WriteLine( " UV,10,,VbInformation+VbSystemModal ")
F.WriteLine( " End If" )
F.WriteLine( " " )
F.WriteLine( " ' Mit ""Notepad.exe"" geöffnete Dateien:" )
F.WriteLine( " '**************************************" )
F.WriteLine( " Set ObjWinGm=GetObject(""WinmGmts:{ImpersonationLevel=""&_ " )
F.WriteLine( " ""Impersonate}!\\.\Root\Cimv2"" )" )
F.WriteLine( " Set Prozesse=ObjWinGm.ExecQuery(""Select * from ""&_ " )
F.WriteLine( " ""Win32_Process where name like '""&Programm&""'"") " )
F.WriteLine( " " )
F.WriteLine( " ' Zum Drucken geöffnete Datei schließen: " )
F.WriteLine( " '*************************************** " )
F.WriteLine( " For each ObjItem in Prozesse " )
F.WriteLine( " If Right(ObjItem.CommandLine,Lang)= _ " )
F.WriteLine( " Fso.GetFileName(Datei) then ObjItem.Terminate " )
F.WriteLine( " Next " )
F.WriteLine( " " )
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Lies ")
F.WriteLine(" ")
F.WriteLine(" Set Data=Fso.OpenTextFile("""&Datei&""") ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until Data.AtEndOfStream ")
F.WriteLine(" ReDim Preserve Zeile(i) ")
F.WriteLine(" Zeile(i)=Data.ReadLine ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" Data.Close ")
F.WriteLine(" Zahl=i-1 ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Schreib0 ")
F.WriteLine(" ")
F.Write(" If Left(Datei,1)="""""""" then ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2) ")
F.WriteLine(" ")
F.WriteLine(" Set Data=Fso.CreateTextFile(Datei) ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until i>Zahl+Anzahl ")
F.WriteLine(" Data.WriteLine(Zeile(i)) ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" Data.Close ")
F.WriteLine(" Set Data=Nothing ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Schreib ")
F.WriteLine(" ")
F.WriteLine(" 'Alte Datei auslesen und Zeilen abändern: ")
F.WriteLine(" '**************************************** ")
F.WriteLine(" Lies ")
F.WriteLine(" ")
F.WriteLine(" 'Leerzeile, Fso/Wss oder Ram-Inhalt einfügen: ")
F.WriteLine(" '******************************************** ")
F.WriteLine(" For k=1 to Anzahl ' Zusätzliche Zeilen def. ")
F.WriteLine(" ReDim Preserve Zeile(Zahl+k) ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" 'Zeilen hinter dem neuen Teil weiterrücken: ")
F.WriteLine(" '****************************************** ")
F.WriteLine(" i=CInt(Zahl)+CInt(Anzahl) ")
F.WriteLine(" Do until i=CInt(Frage)+CInt(Anzahl) ")
F.WriteLine(" Zeile(i)=Zeile(i-CInt(Anzahl)) ")
F.WriteLine(" i=i-1 ")
F.WriteLine(" Loop ")
F.WriteLine(" 'Die neuen Zeilen werden jetzt eingerückt: ")
F.WriteLine(" '***************************************** ")
F.WriteLine(" For i=1 to Anzahl ")
F.WriteLine(" Zeile(Frage+i)=Reihe(Frage+i) ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" 'Die neue Datei schreiben und dann aufrufen: ")
F.WriteLine(" '******************************************* ")
F.WriteLine(" Schreib0 ")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Loeschen ")
F.WriteLine(" ")
F.WriteLine(" Frage=CInt(Document.All.ZeilNr.Value) ")
F.WriteLine(" If Frage=""1"" then ")
F.WriteLine(" MsgBox VbCR&"" Die erste Zeile ist nicht zu löschen ! "" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" If Frage=Ende-NochA then ")
F.WriteLine(" MsgBox VbCR&"" Die letzte Zeile ist nicht zu löschen ! """)
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" 'Jetzigen Zustand der Datei sichern: ")
F.WriteLine(" '*********************************** ")
F.Write(" If Left(Datei,1)="""""""" then ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2)")
F.Write(" If Left(DateiOld,1)="""""""" then ")
F.WriteLine(" DateiOld=Mid(DateiOld,2,Len(DateiOld)-2) ")
F.WriteLine(" Fso.CopyFile Datei,DateiOld ")
F.WriteLine(" ")
F.WriteLine(" 'Alte Datei auslesen und Zeilen abändern: ")
F.WriteLine(" '**************************************** ")
F.WriteLine(" Lies ")
F.WriteLine(" ")
F.WriteLine(" 'Eine bestimmte Zeile soll gelöscht werden: ")
F.WriteLine(" '****************************************** ")
F.WriteLine(" For i=Frage to (Zahl-1) ")
F.WriteLine(" Zeile(i)=Zeile(i+1) ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" 'Datei neu schreiben und dabei abändern: ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" Zahl=Zahl-1 ")
F.WriteLine(" Schreib0 ")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" " )
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Return ")
F.WriteLine(" ")
F.Write(" If Left(DateiOld,1)="""""""" then ")
F.WriteLine(" DateiOld=Mid(DateiOld,2,Len(DateiOld)-2) ")
F.WriteLine(" If not Fso.FileExists(DateiOld) then ")
F.WriteLine(" MsgBox VbCR&"" Die Datei wurde nicht geändert ! "" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.Write(" If Left(DateiNeu,1)="""""""" then ")
F.WriteLine(" DateiNeu=Mid(DateiNeu,2,Len(DateiNeu)-2) ")
F.WriteLine(" If not Fso.FileExists(DateiOld) then Exit Sub ")
F.Write(" If Left(Datei,1)="""""""" then ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2) ")
F.WriteLine(" ")
F.WriteLine(" 'Widerruf auch wieder rückgängig machen können: ")
F.WriteLine(" '********************************************** ")
F.WriteLine(" Fso.CopyFile Datei,DateiNeu,true ")
F.WriteLine(" Fso.CopyFile DateiOld,Datei,true ")
F.WriteLine(" Fso.DeleteFile DateiOld,true ")
F.WriteLine(" Fso.MoveFile DateiNeu,DateiOld ")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Speicher ")
F.WriteLine(" ")
F.WriteLine(" Spch=""1"" 'Nötig wegen Folgebefehlen in Speichern!")
F.WriteLine(" Speichern ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*********************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Speichern ")
F.WriteLine(" ")
F.WriteLine(" Neues=Document.All.Linie.Value ")
F.WriteLine(" Neues0=Neues ") 'Richtige Zeile sichern !
F.Write(" If Left(Datei, 1)="""""""" then ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2) ")
F.Write(" If Left(DateiOld,1)="""""""" then ")
F.WriteLine(" DateiOld=Mid(DateiOld,2,Len(DateiOld)-2) ")
F.WriteLine(" Fso.CopyFile Datei,DateiOld ")
F.WriteLine(" ")
F.WriteLine(" 'Fragzeil hat statt Leerstellen, Neues nicht ! ")
F.WriteLine(" 'Und es sind " statt der "" , in Neues nicht ! ")
F.WriteLine(" '*************************************************** ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until Mid(Neues,i,1)="""" ")
F.WriteLine(" If Mid(Neues,i,1)="" "" then ")
F.WriteLine(" Neues=Left(Neues,i-1)&"" ""&_ ")
F.WriteLine(" Right(Neues,Len(Neues)-i) ")
F.WriteLine(" End If ")
F.WriteLine(" If Mid(Neues,i,1)="""""""" then ")
F.WriteLine(" Neues=Left(Neues,i-1)&"""""&_ ")
F.WriteLine(" Right(Neues,Len(Neues)-i) ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" If (Verschd=""0"" and Anders=""0"" and NeuD=""0"") then ")
F.WriteLine(" If (Neues<>FragZeil) then ")
F.WriteLine(" Ask=MsgBox ( UV&""Die Zeile im Textfeld wurde ver""&_ ")
F.WriteLine(" ""ändert ! ""&UV&"" Wollen Sie die Änder""&_")
F.WriteLine(" ""ung speichern ?"",VbCritical+VbYesNo) ")
F.WriteLine(" If Ask=""7"" then Exit Sub ")
F.WriteLine(" else ")
F.WriteLine(" MsgBox UV&""Die Zeile im Textfeld ist unver""&_ ")
F.WriteLine(" ""ändert ! ""&UV,VbCritical")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" If NeuD=""1"" then ")
F.WriteLine(" Ask=MsgBox(UV&UV&""Wollen Sie eine neue Datei ein""&_ ")
F.WriteLine(" ""richten ? ""&UV&UV,VbCritical+VbOkCancel) ")
F.WriteLine(" If Ask=""2"" then ")
F.WriteLine(" Nein=""1"" ' Für Abbruch in Sub DatNeu! ")
F.WriteLine(" NeuD=""0"" ' Variable ganz zurücksetzen ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" If Ask=""1"" then Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" 'Alte Datei auslesen und Zeile ändern: ")
F.WriteLine(" '************************************* ")
F.WriteLine(" Lies ")
F.WriteLine(" ")
F.WriteLine(" Zeile(Frage)=Neues0 ")
F.WriteLine(" ")
F.WriteLine(" 'Die Datei mit neuer Zeile schreiben : ")
F.WriteLine(" '************************************* ")
F.WriteLine(" Schreib0 ")
F.WriteLine(" ")
F.Write(" If (not (Folge=""0"" or Folge="""") or Folge=")
F.WriteLine(" ""Sonder"") then Ruf ") ' Neuaufruf
F.WriteLine(" If Spch=""1"" then Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Ziel ")
F.WriteLine(" ")
F.WriteLine(" 'Ziel-Ordner und die Datei auswählen : ")
F.WriteLine(" '************************************* ")
F.WriteLine(" Set Sha=CreateObject(""Shell.Application"") ")
F.WriteLine(" Set Fld=Sha.BrowseForFolder(0,StrPrompt,BrowseInfo,Root) ")
F.WriteLine(" ")
F.WriteLine(" On Error Resume Next ")
F.WriteLine(" Err.Clear ")
F.WriteLine(" Pfad=Fld.Self.Path ")
F.WriteLine(" If Err.Number>0 then WScript.Quit ")
F.WriteLine(" Set All=Nothing ")
F.WriteLine(" " )
F.WriteLine(" If Pfad="""" then Exit Sub ") 'Bei Abbruch!
F.WriteLine(" ")
F.WriteLine(" On Error GoTo 0 'Ignorieren wieder aufheben ! ")
F.WriteLine(" Fragen=InputBox(UV&VbCr&""Bitte ergänzen Sie hier""&_")
F.WriteLine(" "" den Namen der ""&UV&_ ")
F.WriteLine(" ""von Ihnen ausgesuchten Zieldatei !""&UV&_")
F.WriteLine(" VbCR,,Pfad&""\"") ")
F.WriteLine(" If Fragen="""" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" 'Nachfrage, wenn die Datei bereits vorhanden : ")
F.WriteLine(" '********************************************* ")
F.WriteLine(" If Fso.FileExists(Fragen) then ")
F.WriteLine(" Ask=MsgBox(UV&UV&""Die Datei existiert bereits ! ""&_ ")
F.WriteLine(" ""Fortsetzen ??? ""&UV&UV,VbCritical+VbYesNo) ")
F.WriteLine(" If Ask=""7"" then Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" Fso.CopyFile Mid(Datei,2,Len(Datei)-1),Fragen ")
F.WriteLine(" Datei=Fragen ")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Aendern ")
F.WriteLine(" ")
F.WriteLine(" FrageAlt=CInt(Frage) ")
F.Write(" If CInt(Frage)=CInt(Document.All.ZeilNr.Value) ")
F.WriteLine(" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Befehl=""Sonder"" ") ' Ausgangspunkt festlegen
F.WriteLine(" " )
F.WriteLine(" Ungleich ") ' Prüfen, ob Zeile geändert
F.WriteLine(" If No=""1"" then ")
F.WriteLine(" Folge=""Sonder"" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" Frage=CInt(Document.All.ZeilNr.Value) ")
F.WriteLine(" If Frage<""1"" then Frage=""1"" ")
F.WriteLine(" If Frage>CInt(Ende)-CInt(NochA) then ")
F.WriteLine(" MsgBox UV&""Die Nummer ist größer als die Zeilenz""&_ ")
F.WriteLine(" ""ahl ""&Ende-NochA&"" ""&UV,VbCritical ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.Write(" If Frage=CInt(Ende)-CInt(NochA) then ")
F.WriteLine(" Start=CInt(Ende)-17 ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Frage)=CInt(Oben) then Start=Start-3 ")
F.WriteLine(" If CInt(Frage)=CInt(Unten) then Start=Start-3 ")
F.WriteLine(" If Start<1 then Start = ""1"" ")
F.WriteLine(" ")
F.WriteLine(" Plus=""1"" ") 'Hier Zusatzzeilen davor setzen
F.WriteLine(" ")
F.WriteLine(" 'Probleme bei Übertragung von Leerstellen vermeiden : ")
F.WriteLine(" '**************************************************** ")
F.WriteLine(" Leerstelle ")
F.WriteLine(" FragZeil=""&&&###;;;"" ") 'Kann Leerstelle enthalten!
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" Self.Close ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Sonder ")
F.WriteLine(" ")
F.WriteLine(" Folge=""0"" ") 'Folgebefehl zuücksetzen!
F.WriteLine(" Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Auf ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Frage)=CInt(Ende)-CInt(NochA) then Exit Sub ")
F.WriteLine(" " )
F.WriteLine(" Befehl=""Auf"" ") ' Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" If CInt(Stoppen)=""1"" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Frage=1+CInt(Frage) ")
F.WriteLine(" If CInt(FrageKorr)-CInt(Start)>=15 then Start=18+Start")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Ab ")
F.WriteLine(" ")
F.WriteLine(" If CInt(Frage)=""1"" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Befehl=""Ab"" ") ' Evtl. Folgebefehl
' Textzeile geändert? Bei Folgebefehl abbrechen :
F.WriteLine(" Aendrg ")
F.WriteLine(" If CInt(Stoppen)=""1"" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Frage=CInt(Frage)-1 ")
F.WriteLine(" If CInt(Start)>CInt(FrageKorr) then Start=Start-30 ")
F.WriteLine(" If Start<""1"" then Start=""1"" ")
F.WriteLine(" ")
F.WriteLine(" Ruf ") ' Neuaufruf
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" " )
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Suchen ")
F.WriteLine(" ")
F.WriteLine(" Wort=InputBox(UV&"" Bitte unten ein zu suchendes ""&_")
F.WriteLine(" ""Wort ein-""&UV&"" geben -- oder mit ### da""&_ ")
F.WriteLine(" ""zwischen ein""&UV&"" neues Wort : es wird für ""&_ ")
F.WriteLine(" ""das 1. gesetzt !""&UV,""Wort suchen - oder ersetzen !!!"") ")
F.WriteLine(" If Wort="""" then Exit Sub ")
F.WriteLine(" ")
F.WriteLine(" Befehl=""Sonder"" ") ' Ausgangspunkt festlegen
F.WriteLine(" " )
F.WriteLine(" Ungleich ")
F.WriteLine(" If No=""1"" then Folge=""Sonder"" ")
F.WriteLine(" ")
F.WriteLine(" 'Wort ohne problem. Leerstellen weitergeben: ")
F.WriteLine(" '******************************************* ")
F.WriteLine(" For i=1 to Len(Wort) ")
F.WriteLine(" ReDim Preserve Wt(i) ")
F.WriteLine(" Wt(i)=Mid(Wort,i,1) ")
F.WriteLine(" If Wt(i)="" "" then Wt(i)=Chr(30) ")
F.WriteLine(" Next ")
F.WriteLine(" Wort=Join(Wt,"""") ")
' Um "Wort" und "Folge" bei Arg.Item(6) unterscheiden zu können !
'****************************************************************
F.WriteLine(" Wort=""&%;""&Wort ")
F.WriteLine(" 'Probleme bei Übertragung von Leerstellen vermeiden: ")
F.WriteLine(" Leerstelle ")
F.WriteLine(" FragZeil=""&&&###;;;"" ") 'Kann Leerstelle enthalten !
F.WriteLine(" ")
F.Write(" Wss.Run Datei0&"" ""&Datei&"" ""&Start&"" ""& ")
F.WriteLine(" FragZeil&"" ""&Frage&"" ""&""1""&"" ""&Plus&"" ""&Wort")
F.WriteLine(" ")
F.WriteLine(" 'Editor nicht schließen und nicht erneut aufrufen!")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Ungleich ")
'Bei evtl. Folgebefehl Dauer-Schleifen vermeiden:
'************************************************
F.WriteLine(" If CInt(Flg)=""1"" then Exit Sub ")
F.WriteLine(" Neues=Document.All.Linie.Value ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until Mid(Neues,i,1)="""" ")
F.WriteLine(" If Mid(Neues,i,1)="" "" then ")
F.WriteLine(" Neues=Left(Neues,i-1)&"" ""&_ ")
F.WriteLine(" Right(Neues,Len(Neues)-i) ")
F.WriteLine(" End If ")
F.WriteLine(" If Mid(Neues,i,1)="""""""" then ")
F.WriteLine(" Neues=Left(Neues,i-1) & """"" &_ ")
F.WriteLine(" Right(Neues,Len(Neues)-i) ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" If not (FragZeil=""&&&###;;;"" or FragZeil=Neues) then ")
F.WriteLine(" If Befehl=""Sonder"" then ")
F.WriteLine(" MsgBox UV&"" Die Textzeile wurde verändert !""&_")
F.WriteLine(" "" Bitte""&UV&"" mit """"Speichern"""" die Z""&_")
F.WriteLine(" ""eile speichern ! ""&UV ")
F.WriteLine(" No=""1"" ")
F.WriteLine(" Exit Sub ")
F.WriteLine(" else ")
F.WriteLine(" Ask=MsgBox(UV&""Wollen Sie diese Änderung speic""&_")
F.WriteLine(" ""hern ? ""&UV,VbCritical+VbYesNo)")
F.WriteLine(" If Ask = ""6"" then ")
F.WriteLine(" If Befehl<> """" then Folge=Befehl ")
F.WriteLine(" Verschd=""1"" ")
F.WriteLine(" Speichern ")
F.WriteLine(" Stoppen=""1"" ")
F.WriteLine(" End If ")
F.WriteLine(" End If ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Leerstelle ")
F.WriteLine(" ")
F.WriteLine(" 'Datei ohne problem. Leerstellen weitergeben: ")
F.WriteLine(" '******************************************** ")
F.WriteLine(" For i= 1 to Len(Datei) ")
F.WriteLine(" ReDim Preserve Wrt(i) ")
F.WriteLine(" Wrt(i)=Mid(Datei,i,1) ")
F.WriteLine(" If Wrt(i)="" "" then Wrt(i)=Chr(30) ")
F.WriteLine(" Next ")
F.WriteLine(" Datei=Join(Wrt,"""") ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Aendrg ")
F.WriteLine(" ")
F.WriteLine(" If Folge=""0"" then ")
F.WriteLine(" Ungleich ") ' Prüfen, ob Textzeile geändert
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" If Stoppen=""0"" then Folge=""0"" ")'Keine Änderung da
F.WriteLine(" If Folge<>""0"" then Self.Close ")'Daueraufruf stoppen
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*********************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Ruf ")
F.WriteLine(" ")
F.WriteLine(" 'Probleme bei Übertragung von Leerstellen vermeiden: ")
F.WriteLine(" '*************************************************** ")
F.WriteLine(" Leerstelle ")
F.WriteLine(" FragZeil=""&&&###;;;"" ") 'Kann Leerstelle enthalten!
F.WriteLine(" ")
F.Write(" Wss.Run Datei0&"" ""&Datei&"" ""&Start&"" ""&FragZeil")
F.WriteLine("&"" ""&Frage&"" ""&""1""&"" ""&Plus&"" ""&Folge ")
F.WriteLine(" Folge=""0"" ") 'Folge wieder zurücksetzen !
F.WriteLine(" Self.Close ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Schliess ")
F.WriteLine(" ")
F.WriteLine(" Neues=Document.All.Linie.Value 'Inhalt der Textzeile ")
F.WriteLine(" ")
F.WriteLine(" 'Neues enthält wieder Leerstellen, erst ersetzen : ")
F.WriteLine(" 'Ebenso müssen die "" "" "" ersetzt werden! ")
F.WriteLine(" i=1 ")
F.WriteLine(" Do until Mid(Neues,i,1)="""" ")
F.WriteLine(" If Mid(Neues,i,1)="" "" then ")
F.WriteLine(" Neues=Left(Neues,i-1)&"" ""&_ ")
F.WriteLine(" Right(Neues,Len(Neues)-i ) ")
F.WriteLine(" End If ")
F.WriteLine(" If Mid(Neues,i,1)="""""""" then ")
F.WriteLine(" Neues=Left(Neues,i-1)&"""""&_ ")
F.WriteLine(" Right(Neues,Len(Neues)-i) ")
F.WriteLine(" End If ")
F.WriteLine(" i=i+1 ")
F.WriteLine(" Loop ")
F.WriteLine(" ")
F.WriteLine(" 'Frage bei Änderung, ob gespeichert werden soll: ")
F.WriteLine(" If (FragZeil<>Neues and not FragZeil=""&&&###;;;"")then")
F.WriteLine(" Ask=MsgBox (UV&UV&""Die Zeile im Textfeld wurde ge""&_ ")
F.WriteLine(" ""ändert ! ""&UV&""Soll diese gespei""&_ ")
F.WriteLine(" ""chert werden ! ? ?""&UV&UV,VbCritical+VbYesNo) ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" If Ask=""6"" then ")
F.WriteLine(" Anders=""1"" ")
F.WriteLine(" Speichern ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" 'Für DatNeu.txt Zielordner und Namen bestimmen! ")
F.WriteLine(" '********************************************** ")
F.WriteLine(" Datei=Mid(Datei,2,Len(Datei)-2) ")
F.WriteLine(" If Right(Datei,10)=""DatNeu.txt"" then ")
F.WriteLine(" ")
F.Write(" MsgBox UV&"" Diese Datei ist mit richtigem Namen ")
F.WriteLine(" zu speichern! ""&UV ")
F.WriteLine(" Set Sha=CreateObject(""Shell.Application"") ")
F.WriteLine(" Set Fld=Sha.BrowseForFolder(0,StrPrompt,BrowseInfo,Root)")
F.WriteLine(" ")
F.WriteLine(" On Error Resume Next ")
F.WriteLine(" Err.Clear ")
F.WriteLine(" Pfad=Fld.Self.Path ")
F.WriteLine(" If Err.Number>0 then WScript.Quit ")
F.WriteLine(" Set All=Nothing ")
F.WriteLine(" ")
F.WriteLine(" If Pfad="""" then Self.Close ") ' Bei Abbruch !
F.WriteLine(" ")
F.WriteLine(" On Error GoTo 0 'Ignorieren wieder aufheben ! ")
F.WriteLine(" Fragen=InputBox(UV&VbCr&""Bitte ergänzen Sie hier""&_")
F.WriteLine(" "" den Namen der ""&UV&_ ")
F.WriteLine(" ""von Ihnen ausgesuchten Zieldatei !""&UV&_")
F.WriteLine(" VbCR,,Pfad&""\"") ")
F.WriteLine(" If Fragen="""" then Self.Close ")
F.WriteLine(" ")
F.WriteLine(" 'Nachfrage, wenn diese Datei bereits vorhanden ist: ")
F.WriteLine(" '************************************************** ")
F.WriteLine(" If Fso.FileExists(Fragen) then ")
F.WriteLine(" Ask=MsgBox(UV&UV&""Die Datei existiert bereits ! ""&_ ")
F.WriteLine(" ""Fortsetzen ??? ""&UV&UV,VbCritical+VbYesNo)")
F.WriteLine(" If Ask=""7"" then Exit Sub ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" Fso.MoveFile(Datei),Fragen ")
F.WriteLine(" End If ")
F.WriteLine(" 'Beim Beenden das temporäre Verzeichnis löschen: ")
F.WriteLine(" '*********************************************** ")
F.WriteLine(" Set Data=Fso.GetFolder(TempVerz).Files ")
F.WriteLine(" For each i in Data ")
F.WriteLine(" Fso.DeleteFile(i) ")
F.WriteLine(" Next ")
F.WriteLine(" Fso.DeleteFolder(TempVerz) ")
F.WriteLine(" Self.Close ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" Sub Eintraege ")
F.WriteLine(" ")
F.Write(" Lin=Lin&""<Input Type=""""Text"""" ")
F.Write(" Style=""""Width:38"""" ")
F.Write(" Name=""""ZeilNr"""" ")
F.WriteLine(" Value="""""&Frage&""""">"" ")
F.WriteLine(" 'Inhalt gezeigter Textzeile richtig stellen: ")
F.WriteLine(" '******************************************* ")
F.WriteLine(" FragZeiln=FragZeil ")
F.WriteLine(" FragZeil="""" ")
F.WriteLine(" For k=1 to Len(FragZeiln) ")
F.WriteLine(" FragZeil=FragZeil&Mid(FragZeiln, _ ")
F.WriteLine(" Len(FragZeiln)+1-k,1) ")
F.WriteLine(" Next ")
F.Write(" Lin=Lin&""<Input Type=""""Text"""" ")
F.Write(" Style=""""Width:710"""" ")
F.Write(" Name=""""Linie"""" ")
F.WriteLine(" Value=""""""&FragZeil&"""""">"" ")
F.Write(" Lin=Lin&"" <Input Type=""""Button"""" ")
F.Write(" Name=""""Anders"""" Style=""""Width:30"""" ")
F.Write(" Value=""""Nr"""" OnClick=""""Aendern"""" ")
F.WriteLine(" Title="""" Ganz links eingetragene Zeile zeigen """"> """)
F.Write(" Lin=Lin&"" <Input Type=""""Button"""" Name= ")
F.Write(" """"X-1"""" Style=""""Width:30"""" Value="""" ")
F.Write(" /\ """" OnClick=""""Ab"""" Title="""" Die vorige ")
F.WriteLine("Zeile aufrufen """">"" ")
F.Write(" Lin=Lin&""<Input Type=""""Button"""" ")
F.Write(" Name=""""X+1"""" Style=""""Width:30"""" ")
F.Write(" Value="""" \/ """" OnClick=""""Auf"""" Title="""" ")
F.WriteLine(" Die nächste Zeile aufrufen """">"" ")
F.Write(" Lin=Lin&"" <Input Type=""""Button"""" ")
F.Write(" Name=""""Suche"""" Style=""""Width:55"""" ")
F.Write(" Value=""""Suche"""" OnClick=""""Suchen"""" Title=""""")
F.Write("Bestimmtes Wort in der Datei suchen oder das Wort")
F.WriteLine(" durch ein anderes ersetzen """" > "" ")
F.WriteLine(" ")
F.WriteLine(" Document.All.MeldZeil.InnerHTML=Lin ")
If ( CInt(Start)+29<CInt(Frage) or CInt(Start)+29<CInt(FrageKorr) _
or CInt(FrageKorr)="1" ) then FrageKorr=CInt(Start)
If CInt(Start)+29<=CInt(Ende) then
Schluss = CInt(Start)+29
else
Schluss = CInt(Ende )
End If
' Es kommt erst der 1. Teil der Blockzeilen :
'********************************************
If CInt(Start)<=CInt(FrageKorr)-1 then
For n=Start to FrageKorr-1
F.WriteLine(" ReDim Preserve Txt("&n&") ")
F.WriteLine(" Txt("&n&")="""&Zeile(""&n&"")&""" ")
'***********************************************************
'* *
'* Die aus den oben genannten Gründen rückwärts geschrie- *
'* benen Zeilen müssen wieder richtig geschrieben werden ! *
'* *
'***********************************************************
F.WriteLine(" ReDim Preserve TxtR("&n&") ")
F.WriteLine(" TxtR("&n&")=Txt("&n&") ")
F.WriteLine(" Txt("&n&")="""" ")
F.WriteLine(" ")
F.WriteLine(" For k=1 to Len(TxtR("&n&")) ")
F.Write(" Txt("&n&")=Txt("&n&")& ")
F.WriteLine(" Mid(TxtR("&n&"), Len(TxtR("&n&"))+1-k, 1) ")
F.WriteLine(" Next ")
F.WriteLine(" 'Problematische ""<"", "">"" verstecken: ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" Txt("&n&")=Replace(Txt("&n&"),""<"",""&60"") ")
F.WriteLine(" Txt("&n&")=Replace(Txt("&n&"),"">"",""&62"") ")
F.WriteLine(" Txt("&n&")=Replace(Txt("&n&"),"" "",XYZ) ")
'Nr. der obersten Zeile auslesen, wenn neutralen Wert:
'**********************************************************
F.WriteLine("If "&n&"=Start then Oben=Left(Txt("&n&"),4) ")
F.WriteLine("If ("&n&"=Start and Oben="""") then Oben=FrageKorr ")
Next
F.WriteLine(" If CInt(FrageKorr)-1>=CInt(Start) then ")
F.WriteLine(" For n=CInt(Start) to CInt(FrageKorr)-1 ")
F.WriteLine(" Text1=Text1&Txt(n)&""<BR>"" ")
F.WriteLine(" Next ")
F.WriteLine(" End If ")
F.WriteLine(" ")
F.WriteLine(" Document.All.Meldung1.InnerHTML=Text1 ")
End If
' Es folgt jetzt der 2. Teil der Blockzeilen :
'*********************************************
For n=1+CInt(FrageKorr) to CInt(Schluss)
'Falls nach der verlangten Zeile noch überhängende Zeilen sind:
'**************************************************************
If n=1+CInt(FrageKorr) then
Lang = Len(Zeile(1 + CInt(FrageKorr)))
If (Mid(Zeile(1+CInt(FrageKorr)),Lang-4,1)<>"&" and _
Mid(Zeile(1+CInt(FrageKorr)),Lang-5,1)<>"#") then
i=1
Do
Lang=Len(Zeile(i+CInt(FrageKorr)))
Zeile(i+CInt(FrageKorr))=" - - - "
i=i+1
Lang = Len(Zeile(i+CInt(FrageKorr)))
Loop until (Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang,1))>47 and _
Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang,1))<58 and _
Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang-1,1))>47 and _
Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang-1,1))<58 and _
Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang-2,1))>47 and _
Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang-2,1))<58 and _
Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang-3,1))>47 and _
Asc(Mid(Zeile(i+CInt(FrageKorr)),Lang-3,1))<58 )
End If
End If
F.WriteLine(" ReDim Preserve Txt("&n&") ")
F.WriteLine(" Txt("&n&")="""&Zeile(""&n&"")&""" ")
'***********************************************************
'* *
'* Die aus den oben genannten Gründen rückwärts geschrie- *
'* benen Zeilen müssen wieder richtig geschrieben werden ! *
'* *
'***********************************************************
F.WriteLine(" ReDim Preserve TxtR("&n&") ")
F.WriteLine(" TxtR("&n&")=Txt("&n&") ")
F.WriteLine(" Txt("&n&")="""" ")
F.WriteLine(" ")
F.WriteLine(" For k=1 to Len(TxtR("&n&")) ")
F.Write(" Txt("&n&")=Txt("&n&")& ")
F.WriteLine(" Mid(TxtR("&n&"),Len(TxtR("&n&"))+1-k,1) ")
F.WriteLine(" Next ")
F.WriteLine(" ")
F.WriteLine(" 'Problemat. "" < "", "" > "" verstecken: ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" Txt("&n&")=Replace(Txt("&n&"),""<"",""&60"") ")
F.WriteLine(" Txt("&n&")=Replace(Txt("&n&"),"">"",""&62"") ")
F.WriteLine(" Txt("&n&")=Replace(Txt("&n&"),"" "",XYZ) ")
Next
F.WriteLine(" '********************************************* ")
F.WriteLine(" 'Evtl. kürzeren letzten Block extra behandeln: ")
F.WriteLine(" '********************************************* ")
F.WriteLine(" If CInt(Start)+29<=CInt(Ende) then ")
F.WriteLine(" Bis=CInt(Start)+29 ")
F.WriteLine(" else ")
F.WriteLine(" Bis=CInt(Ende) ")
F.WriteLine(" End If ")
F.WriteLine(" For n=1+CInt(FrageKorr) to Bis ")
F.WriteLine(" Text2=Text2&Txt(n)&""<BR>"" ")
' Nr. der untersten Zeile auslesen, wenn neutralen Wert :
'*************************************************************
F.WriteLine(" If n=Bis then Unten=Left(Txt(Bis),4) ")
F.WriteLine(" If (n=Bis and Unten="""") then Unten=FrageKorr ")
F.WriteLine(" Next ")
F.WriteLine(" 'In evtl. kürzerem letzten Block Rest Leerzeilen: ")
F.WriteLine(" '************************************************ ")
If Ende-Start<29 then
For i=1 to (Start+29-Ende)
F.WriteLine(" Text2=Text2&""<BR>"" ")
Next
End If
F.WriteLine(" Document.All.Meldung2.InnerHTML=Text2 ")
F.WriteLine(" ")
F.WriteLine(" End Sub ")
F.WriteLine(" ")
F.WriteLine(" '*************************************** ")
F.WriteLine(" ")
F.WriteLine(" </Script> ")
F.WriteLine(" </Head> ")
F.WriteLine(" <Title> VbsEditor : . . . . . . . . . . . . . . . . " )
F.Write(" """&Datei&""". . . . . . . . . . . . . . . . </Title>")
F.WriteLine(" <Body OnLoad=""Eintraege"" bgcolor=""#d2b470""> ")
F.WriteLine(" <Form> ") '#f0e68c maisgelb/ #d2b470 hellbraun
F.Write(" <Table Border=""6"" Cellspacing=""10px"" ")
F.WriteLine(" Width=""100%"" > ")
F.WriteLine(" <Tr> ") '#f5fffa hellsilber/#90ee90 hellgrün
F.WriteLine(" <Td bgcolor=#fffffa> ") '#hffffh hellblau
If CInt(FrageKorr)>CInt(Start) then 'Falls erster Teil da
F.WriteLine(" <Div Id=Meldung1></Div> ")
End If
F.WriteLine(" <Div Id=MeldZeil></Div> ")
F.WriteLine(" <Div Id=Meldung2></Div> ")
F.WriteLine(" <Center> ")
F.WriteLine(" <BR> ")
F.Write(" <Input Type=""Button"" Name=""Beginn!"" ")
F.Write(" Value="" |< "" OnClick=""Beginn"" ")
F.WriteLine(" Title="" Ersten Zeilenblock anzeigen ""> ")
F.Write(" <Input Type=""Button"" Name=""Zurück!"" ")
F.Write(" Value=""<<"" OnClick=""Zurueck"" ")
F.WriteLine(" Title="" Vorigen Zeilenblock anzeigen ""> ")
F.Write(" <Input Type=""Button"" Name=""Weiter!"" ")
F.Write(" Value="">>"" OnClick=""Weiter"" ")
F.WriteLine(" Title="" Nächsten Zeilenblock anzeigen ""> ")
F.Write(" <Input Type=""Button"" Name=""Letztes"" ")
F.Write(" Value="" >| "" OnClick=""Grenze"" ")
F.WriteLine(" Title="" Letzten Zeilenblock anzeigen ""> ")
F.Write(" <Input Type = ""Button"" Name = ")
F.Write(" ""Neu!"" Value="" Neu "" OnClick=""DatNeu"" ")
F.WriteLine(" Title="" Eine neue, leere Datei erschaffen ""> ")
F.Write(" <Input Type=""Button"" Name= ")
F.Write(" ""Oeffnen!"" Value=""Öffnen"" OnClick=""Oeffnen"" ")
F.WriteLine(" Title="" Eine andere Datei neben dieser öffnen""> ")
F.Write(" <Input Type=""Button"" Name=""Speichern"" ")
F.Write(" Value=""Speichern"" OnClick=""Speicher"" ")
F.WriteLine(" Title="" Die veränderte Zeile Nr. speichern ""> ")
F.Write(" <Input Type=""Button"" Name=""Unter"" Value=""")
F.Write(". . in "" OnClick=""Ziel"" ")
F.WriteLine(" Title="" Diese Datei speichern unter . . . "" > ")
F.Write(" <Input Type=""Button"" Name=""")
F.Write(" Loesch"" Value=""Lösche"" OnClick=""Loeschen"" ")
F.WriteLine(" Title="" Die Zeile Nr. löschen ""> ")
F.Write(" <Input Type=""Button"" ")
F.Write(" Name=""Widerruf"" Value=""<<<"" OnClick=""Return"" ")
F.WriteLine(" Title="" Die letzte Aktion widerrufen ""> ")
F.Write(" <Input Type=""Button"" Name="" ")
F.Write(" NeuZeil"" Value=""Leer"" OnClick=""NeuZeile"" ")
F.WriteLine(" Title="" Nach Zeile Nr. Leerzeile einfügen ""> ")
F.Write(" <Input Type=""Button"" Name=""Ram !"" ")
F.Write(" Value=""Ablage"" OnClick=""Ram"" ")
F.Write(" Title = "" Nach Zeile Nr. als neue Zeilen die Zwischenab - ")
F.WriteLine(" lage einfügen ! ( Anklicken, mit Strg + C dahin! ) ""> ")
F.Write(" <Input Type=""Button"" Name=""Objekte"" ")
F.Write(" Value=""Objekt"" OnClick=""Objkt"" ")
F.WriteLine(" Title="" Nach Zeile Nr. ein gewünschtes Objekt setzen ""> ")
F.Write(" <Input Type=""Button"" Name=""Drucken"" ")
F.Write(" Value=""Drucken"" OnClick=""Druckn"" ")
F.WriteLine(" Title="" Die vorliegende Datei drucken ! ""> ")
F.Write(" <Input Type=""Button"" Name= ")
F.Write(" ""Ende"" Value="" X "" OnClick=""Schliess"" ")
F.WriteLine(" Title="" Editor samt Hilfsdateien schließen ! "" > ")
F.WriteLine(" <BR><BR> ")
' Am Schluss Angaben über Zeit und die Datei :
'*********************************************
F.Write(" Heute ist "&Left(Tg,2)&"., der "&Date&", ")
F.Write(" "&Left(Time,5)&" Uhr! Die Datei hat "&Ende-NochA&" Zei")
F.Write("len mit "&Gross&" B, wurde am "&Left(Aenderg, 10)&" um ")
F.WriteLine(" "&Left(Right(Aenderg,8),5)&" zuletzt geändert!<Br> ")
' F.WriteLine(" "&Timer-Zeit&" ") 'Ggf. Zeitmessung
F.WriteLine(" </Center> ")
F.WriteLine(" ")
F.WriteLine(" </Td> ")
F.WriteLine(" </Tr> ")
F.WriteLine(" </Body> ")
F.WriteLine(" </Html> ")
F.Close
Set F = Nothing
End If
'##############################################################
'# #
'# Diese gerade geschriebene H - t - a - Datei nun aufrufen , #
'# außer im Falle, die Suche eines Wortes wurde durchgeführt! #
'# #
'##############################################################
On Error Resume Next
' Bei der Suche eines Wortes geschieht kein neuer Aufruf :
'*********************************************************
If Wort="0" then
DateiZ=TempVerz&"DateiZeigen."&"h"&"t"&"a"
Wss.Run DateiZ,,true
If Fso.FileExists(DateiZ) then Fso.DeleteFile(DateiZ)
End If
' Bei Sucherfolg Datei mit Zeilen-Nr. zeigen & löschen :
'*******************************************************
If Fso.FileExists(DateiN) then
Wss.Run "Notepad """&DateiN&""" "
WScript.Sleep 500
Fso.DeleteFile DateiN
End If
On Error GoTo 0
WScript.Quit
#########################################################################
>>> vbsremotestarten.vbs <<<
'*** v8.4 *** www.dieseyer.de ******************************
'
' Datei: vbsremotestarten.vbs
' 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
Dim AktVerz : AktVerz = Replace( WScript.ScriptFullName, WScript.ScriptName, "" ) ' mit "\" am Ende!!!
Dim ZielPC : ZielPC = "192.168.13.33"
ZielPC = "PC01"
Dim ZielAnw : ZielAnw = AktVerz & "WMIRepair.cmd"
ZielAnw = "shutdown -r -f -t 99"
' LOG-Datei-Namen festlegen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim LogDatei, Txt
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
LogDatei = WScript.ScriptFullName & ".log"
' Trace32Log "-", 0 ' erstellt neue LogDatei (wegen 0)
Trace32Log " ", 1 ' fügt Leerzeile in LogDatei ein
Trace32Log "040 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "041 :: LogDatei: " & LogDatei, 1
Trace32Log "042 :: AktVerz: " & AktVerz, 1
Trace32Log "043 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "044 :: Angemeldeter User: " & WSHNet.UserName, 1
Trace32Log "045 :: ZielPC: " & ZielPC, 1
' ZielPC erreichbar?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not WMIpingOK( ZielPC ) Then
Txt = "ZielPC """ & ZielPC & """ ist nicht erreichbar."
Trace32Log "052 :: " & Txt, 2
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 17, "053 :: " & WScript.ScriptName
Trace32Log "054 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 3
LogDatei = "" : Trace32Log "Ende: """ & ZielPC & """ - " & Txt, 3 ' LOG-Datei ist VBS-Name
MsgBox now() & vbCRLF & Txt, , "056 :: " & "= = = E N D E = = ="
WScript.Quit
End If
Txt = "ZielPC ist per WMI-Ping erreichbar: " & ZielPC : Trace32Log "059 :: " & Txt, 1 : ' WSHShell.Popup now() & vbCRLF & Txt, 5, "059 :: " & "= = = E N D E = = ="
Call VbsRemoteStarten( ZielPC, ZielAnw )
WSHShell.Popup vbTab & "= = = E N D E = = =" & vbCRLF & vbCRLF & Txt & vbCRLF & vbCRLF & vbTab & ZielPC, 3, "063 :: " & WScript.ScriptName
Trace32Log "065 :: " & Txt, 1
Trace32Log "066 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
LogDatei = "" : Trace32Log "Abgearbeitet: """ & ZielPC & """ " , 1 ' LOG-Datei ist VBS-Name
WScript.Quit
'*** v8.4 *** www.dieseyer.de ******************************
Function VbsRemoteStarten( ZielPC, Progr )
'***********************************************************
Dim Tx, Tst, ProcessID
' Progr = "wscript.exe " & Progr ' Ziel-Anwendung
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ZielPC & "\root\cimv2")
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 "085 :: Soll gestartet werden: """ & Progr & """ ", 1
Tst = objProcess.Create( Progr, Null, objConfig, ProcessID )
' Tst = objProcess.Create( Progr, CreateObject("WScript.Shell").ExpandEnvironmentStrings("%WinDir%") & "\system32", objConfig, ProcessID )
If Tst <> 0 Then
Trace32Log "089 :: Konnte NICHT gestartet werden - RC " & Tst, 3
Else
Trace32Log "091 :: Ist gestartet - Process ID: " & ProcessID, 1
End If
' c:\WINDOWS\system32\rundll32.exe"
End Function ' VbsRemoteStarten( ZielPC, Progr )
'*** v6.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 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("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'*** 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 )
#########################################################################
>>> vbstxtdocsuchmaschine.vbs <<<
'*** v8.8 *** www.dieseyer.de ******************************
'
' Datei: VbsTxtDocSuchmaschine.vbs
' Autor: W.Schmelz
' Auf: www.dieseyer.de
'
'In den VBS-Dateien des Ordners wird gleich ein eingegebener
'Begriff gesucht - oder zwei durch Komma getrennte eingebene
'Begriffe. Bei nur einer Fundstelle wird der Inhalt der ein-
'zigen gefundenen Datei in einer Hilfs- Datei angezeigt, die
'sich selbst löscht! Bei mehreren Fundstellen werden diese
'zunächst alle genannt und es ist möglich, die erste gefund-
'ene Datei auszugeben, eine ausgesuchte oder alle hinterein-
'ander weg gesetzt! Von allen weiteren Fundstellen werden am
'Ende die Namen genannt!
'
'Auch andere Dateiarten wie "Txt" können durchsucht werden,
'sogar Doc-Dateien sind jetzt möglich geworden !!
'Wichtig ist: Nichts Aufwändiges nebenher laufen lassen !!!
'
'Die gefundenen Zeilen werden mit 11111 oder 22222 markiert!
'***********************************************************
'CopyRight W. Schmelz, 25.07.2008
'Die Objekte u. a. werden für das Programm bereit gestellt:
'**********************************************************
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Arg=Wscript.Arguments
Dim Titel, AktVerz, Zwei, Word, Hier1, Zahl, ZahlR, DMax, N1
Dim Datei, Zeile(), Linie(), Numm(), Endg, Ende(), Zahl1, UV
Dim Zahl2, DZahl, Hier2, Hier, Neu, Einzel, ZahlDoc, Linien()
Titel=" Begriffe in VBS-Sammlung suchen"
UV=VbCR&VbCR
'Den Namen des Startordner suchen, die Ausgabedatei benennen:
'************************************************************
AktVerz=Fso.GetParentFolderName(WScript.ScriptFullName)
DateiM=Fso.GetBaseName(WScript.ScriptFullName)&"-M.txt"
DateiM=AktVerz&"\"&DateiM
DateiS=Fso.GetBaseName(WScript.ScriptFullName)&"-S.txt"
DateiS=AktVerz&"\"&DateiS
'Die Festlegung der zu untersuchenden Dateien - oder Abbruch:
'************************************************************
Endg=InputBox(UV&UV&_
" Geben Sie ein, welche Dateien im Ordner"&UV&_
" auf die gleich fest zu legenden Begriffe"&UV&_
" durchsucht werden ! ""Vbs"", ""Txt"", ""Doc"""&UV&_
" sind prüfbar. Bei ""Doc"" sind unbedingt"&UV&_
" Scanner und Aufwändiges zu schließen!"&UV&_
" Zur Sicherheit besser immer so halten!"&_
UV&UV,Titel,"vbs")
Endg=LCase(Endg)
If Endg="" then WScript.Quit
'Die Abfrage der zu suchenden Begriffe - oder doch ein Abbruch:
'**************************************************************
Word=InputBox(UV&UV&_
" Geben Sie den zu suchenden Begriff ein !"&UV&_
" Große und kleine Buchstaben sind egal !"&UV&_
" In allen Dateien wird der Begriff gesucht!"&UV&_
" Alle gefundenen Dateien werden genannt !"&UV&_
" Erste Datei, bestimmte, alle sind einsehbar !"&UV&_
" Die Fundzeilen sind mit Zeichen markiert !"&UV&_
" Sogar zwei Worte mit "" , "" sind möglich !!"&_
UV&UV,Titel,"winmg,process")
Word=LCase(Word)
If Word="" then WScript.Quit
'Die evtl. eingetragenen Leerstellen beseitigen,
'denn sie könnten Probleme bei der Suche ergeben !
'*************************************************
Neu=""
For i=1 to Len(Word)
Stelle=Mid(Word,i,1)
If not Stelle=" " then Neu=Neu&Stelle
Next
Word=Neu
'Prüfen, ob mehr als zwei Worte eingetragen worden sind:
'*******************************************************
N1="0" 'Dafür die Zahl der Kommata prüfen
For i=1 to Len(Word)
If Mid(Word,i,1)="," then N1=1+N1
Next
'Abbruch, wenn mehr als ein Komma bzw. 2 Worte vorkommen:
'*********************************************************
If N1>1 then MsgBox UV&VbCR&"In der Eingabe "&_
"sind zuviele Kommata ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Wurden eine oder zwei Eingaben in "Word" aufgefunden?
'*****************************************************
Zwei="0"
For i=1 to Len(Word)
If Mid(Word,i,1)="," then Zwei="1"
Next
'Die Eingabe ggf. aufsplitten in Wort(0) und Wort(1):
'******************************************************
Wort=Split(Word,",")
'Der Abbruch, wenn Wort(1)= "" oder nur 1 Buchstaben hat:
'********************************************************
If Zwei="1" then
If (Wort(1)="" or Len(Wort(1))=1) then MsgBox UV&VbCR&_
"Das zweite Wort "&_
"war leer oder sinnlos ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
End If
'Die "Endg" - Dateien in "AktVerz" zählen, durchbenennen:
'********************************************************
Set Data=Fso.GetFolder(AktVerz).Files
DZahl="0"
i=1
For each File in Data
ReDim Preserve Dat(i)
If LCase(Fso.GetExtensionName(File))=Endg then
Dat(i)=File
DZahl=1+DZahl
i=i+1
End If
Next
'Prüfen, ob gewünschte Dateien im Ordner überhaupt da sind:
'**********************************************************
If DZahl="0" then MsgBox UV&VbCR&"In diesem Ordner "&_
"ist keine "" "&Endg&" "" - Datei ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Falls jetzt Word-Dateien untersucht werden sollen:
'**************************************************
If Endg="doc" then
If not Fso.FolderExists(AktVerz&"\DocDoc") then _
Set Ordn=Fso.CreateFolder (AktVerz&"\DocDoc")
WordDoc
End If
'Die Länge Ende(i) aller Dat(i) ermitteln:
'*****************************************
i=1
Do until i>DZahl
ReDim Preserve Ende(i) 'Länge von Dat(i)
Set File=Fso.OpenTextFile(Dat(i),1,true) 'Dat(i) öffnen
'Dafür die Zeilen von Dat(i) auslesen:
'*************************************
k=1
Do until File.AtEndOfStream
ReDim Preserve Linie(k)
Linie(k)=File.ReadLine
k=k+1
Loop
Ende(i)=k-1 'Länge von Dat(i)
File.Close
Set File=Nothing
i=i+1
Loop
'Die größte aller der vorkommenden Dateilängen ermitteln:
'*********************************************************
DMax="1"
For a=1 to DZahl
If Ende(a)>Int(DMax) then DMax=Ende(a)
Next
'Alle "Endg"-Dateien öffnen, alle Zeilen nummeriert lesen:
'*********************************************************
'In Zeile(i,k) ist das i die Datei-Nr. und k die Zeilen-Nr
ReDim Preserve Zeile(DZahl,DMax) 'Darf nur 1x definiert
'werden, daher auf einmal festlegen, mit DMax !
i=1
Do until i>DZahl
Set File=Fso.OpenTextFile(Dat(i),1,true) 'Dat(i) öffnen
'Zeilen(i,k) in Dat(i) festlegen
k=1
Do until k>Ende(i)
Zeile(i,k)=File.ReadLine
k=k+1
Loop
File.Close
Set File=Nothing
i=i+1
Loop
'Die Suche des Begriffes 1 in allen den Zeilen(i,k):
'****************************************************
Hier1=""
Zahl1="0" 'Zahl der Fundstellen
For i=1 to DZahl
For k=1 to Ende(i)
l=1
Do until l>Len(Zeile(i,k))-Len(Wort(0))+1
If LCase(Mid(Zeile(i,k),l,Len(Wort(0))))=Wort(0) then
If Len(Hier1)>0 then Hier1=Hier1&"|"&i&","&k
If Hier1="" then Hier1=i&","&k
Zahl1=Zahl1+1 'Wie oft "Wort(0)" gefunden ?
End If
l=l+1
Loop
Next
Next
'Ein Abbruch - falls nichts zu finden war:
'*****************************************
If Hier1="" then MsgBox UV&VbCR&"Der Begriff "" "&_
Wort(0)&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Die Aufsplittung der Fundorte in Ort1(i), erster ist Ort1(0):
'*************************************************************
Ort1=Split(Hier1,"|")
Fund=Ort1(0)
'Die Fundstellen für Wort 1 werden am Zeilenende markiert:
'*********************************************************
i=0
Do until i=Zahl1
Nr=Split(Ort1(i),",") 'Ort1(i) in 2 Zahlen splitten
'Wenn noch nicht markiert:
If not Right(Zeile(Nr(0),Nr(1)),5)="11111" then
Zeile(Nr(0),Nr(1))=Zeile(Nr(0),Nr(1))&" 1111111111"
End If
i=i+1
Loop
'*******************************************************
'Bei zwei Begriffen die gemeinsamen Fundorte ermitteln !
'Am Ende wird so bezeichnet wie bei nur einem Begriff,
'damit die Ausgabe so erfolgt wie bei einem Begriff !!!
'*******************************************************
If Zwei="1" then Doppel 'Sub - Programm aufrufen
'" Txt " - Hilfsdateien und Ordner " DocDoc " wieder löschen:
'************************************************************
If LCase(Endg)="doc" then
For i=1 to DZahl
If Fso.FileExists (Dat(i)) then _
Fso.DeleteFile Dat(i)
Next
WScript.Sleep 500
If Fso.FolderExists (AktVerz&"\DocDoc") then _
Fso.DeleteFolder AktVerz&"\DocDoc"
End If
'Die gefundenen Datei-Nrn. (auf keinen Fall doppelt) auflisten:
'**************************************************************
Rest=Fund
k=1
Do until k=Zahl1
Nr1=Split(Ort1(k),",") 'Ort1(k) in 2 Zahlen splitten
Nr0=Split(Ort1(k-1),",") 'Ort1 davor auch!
If (Ort1(k)<>Fund and Nr1(0)<>Nr0(0)) then
Rest=Rest&"|"&Ort1(k)
End If
k=k+1
Loop
'Wieviele Fundstellen sind da?
'*****************************
Test=InStr(Rest,"|") 'Wann "Fund" zu Ende ?
'Bei nur einem Fund diesen dann melden:
'**************************************
ReDim Preserve Numm(1)
If Test=0 then
Ask="a" 'Ersten und einzigen Fundort melden
Einzel="1"
Numm(1)=Left(Fund,1)
End If
'Falls mehrere Fundstellen zu beiden Begriffen zu finden waren:
'**************************************************************
If Test>0 then ' "End If" s.u. <<<<<<<<<<<<<<<<<<
Rest=Right(Rest,Len(Rest)-Test) 'Restliche Fundorte
ZahlR="1" 'Die Anzahl der restlichen Fundorte:
For i=1 to Len(Rest)
If Mid(Rest,i,1)="|" then ZahlR=1+ZahlR
Next
'Der Name der ersten Fundstellen - Datei:
'****************************************
ReDim Preserve Numm(1+ZahlR)
Nr=Split(Fund,",")
Numm(1)=Nr(0)
Fund=Dat(Nr(0))
Txt1="1) "&Fso.GetFileName(Fund)
'Die weiteren, gefundenen Abschnitte aufsplitten, Noch(0) usw.:
'**************************************************************
Noch=Split(Rest,"|")
'Die restlichen Dateien auflisten in "Txt":
'******************************************
For i=1 to ZahlR
Nr=Split(Noch(i-1),",")
Numm(i+1)=Nr(0)
Txt=Txt&VbCR&i+1&") "&Fso.GetFileName(Dat(Nr(0)))
If i=1 then Txt=i+1&") "&Fso.GetFileName(Dat(Nr(0)))
Next
'Die gefundenen Dateien aufsplitten:
'***********************************
Ergbn=Split(Txt,VbCR)
'Die größte Dateinamenlänge ermitteln:
'*************************************
NMax="1"
For a=0 to ZahlR-1
If Len(Ergbn(a))>Int(NMax) then NMax=Len(Ergbn(a))
Next
'Die gefundenen Dateien mit Leerstellen auf gleiche Länge bringen:
'*****************************************************************
Lang=" "
For i=1 to Int(NMax)+3
Lang=Lang&" " 'Gesamtlänge festlegen
Next
Txt2=""
For i=0 to ZahlR-1
Txt2=Txt2&Ergbn(i)&Right(Lang,NMax+3-Len(Ergbn(i)))
If i mod 3=2 then Txt2=Txt2&VbCRLF
Next
'****************************************************************
' Für mehr als 10 Funddateien in einer Meldedatei alle gefundenen
' Dateien anzeigen und in einer Input - Box nach Weiterem fragen,
' denn in jeder Art Box ist nur begrenzter Platz zur Verfügung !
'****************************************************************
If ZahlR>=10 then 'Zahl der zusätzlichen Fundstellen
'Die Melde - Datei aller Fundorte schreiben:
'*******************************************
Set File=Fso.OpenTextFile(DateiM,2,true)
File.WriteLine(" ")
File.Write("Außer der ersten Datei "&Txt1)
File.WriteLine(" wurden folgende Dateien gefunden !")
File.WriteLine(" ")
File.WriteLine(Txt2)
File.Close
Set File=Nothing
'Alle gefundenen Dateien in Txt - Datei mit Anweisungen anzeigen:
'****************************************************************
Wss.Run "Notepad """&DateiM&""" "
WScript.Sleep 2000
'Die Nachfrage, was als Ausgabe gewünscht wird:
'**********************************************
Ask=InputBox(UV&VbCR&_
" Bei "" a "" wird die obige erste Datei ange -"&VbCR&_
" zeigt, die weiteren Dateien nur genannt !"&VbCR&_
" Bei "" b "" werden sämtliche Dateien ein -"&VbCR&_
" zeln und aufeinander folgend angezeigt !"&VbCR&_
" Oder geben Sie die gewünschte Nr. ein !"&UV&_
VbCR,Titel,"a")
Word=LCase(Word)
If Ask="" then WScript.Quit
End If
'****************************************************************
' Für 1 bis 10 Funddateien diese anzeigen und die Möglichkeit er-
' öffnen, alle Dateien zusammen anzuzeigen - oder nur bestimmte !
'****************************************************************
If ZahlR<=9 then 'Zahl der zusätzlichen Fundstellen
'Die Nachfrage, was als Ausgabe gewünscht wird:
'**********************************************
Ask=InputBox(VbCR&_
" Das Programm hat außer dieser 1. Datei :"&UV&_
Txt1&UV&_
" noch diese folgenden Dateien gefunden :"&VbCR&_
Txt&UV&_
" Bei "" a "" wird die obige erste Datei ange -"&VbCR&_
" zeigt, die weiteren Dateien nur genannt !"&VbCR&_
" Bei "" b "" werden sämtliche Dateien ein -"&VbCR&_
" zeln und aufeinander folgend angezeigt !"&VbCR&_
" Oder geben Sie die gewünschte Nr. ein !"&_
VbCR,Titel,"a")
Word=LCase(Word)
If Ask="" then WScript.Quit
End If
End If ' "If" s.o. <<<<<<<<<<<<<<<<<<
'################################################################
'Die Ausgabedatei öffnen und die gefundenen Dateien ausschreiben:
'################################################################
Set File=Fso.OpenTextFile(DateiS,2,true)
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
'Die erste Fundstelle ausgeben:
'******************************
If (Ask="a" or Ask="1") then
'Fundstelle benennen:
If Einzel<>"1" then File.Write("Die erste gefundene Datei heißt")
If Einzel="1" then File.Write("Einzige gefundene Datei ist")
File.WriteLine(" : "" "&Dat(Numm(1))&" "" ")
File.Write("####################################")
File.WriteLine("###################################")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
i=1
Do until i=Ende(Numm(1))+1
File.WriteLine(Zeile(Numm(1),i))
i=i+1
Loop
End If
'Sämtliche Fundstellen ausgeben:
'*******************************
If Ask="b" then
For k=1 to 1+ZahlR
'Fundstellen benennen:
File.Write("Die "&k&". te gefundene Datei heißt : "" ")
File.WriteLine(Dat(Numm(k))&" "" ")
File.Write("##################################")
File.WriteLine("#####################################")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
i=1
Do until i>Ende(Numm(k))
File.WriteLine(Zeile(Numm(k),i))
i=i+1
Loop
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
Next
End If
'Eine gewünschte Fundstelle wird ausgegeben:
'*******************************************
If not (Ask="a" or Ask="b") then
'Gewünschte Fundstelle benennen:
File.Write("Die "&Ask&". te gefundene Datei heißt : "" ")
File.WriteLine(Dat(Numm(Ask))&" "" ")
File.Write("##################################")
File.WriteLine("#####################################")
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine(" ")
i=1
Do until i>Ende(Numm(Ask))
File.WriteLine(Zeile(Numm(Ask),i))
i=i+1
Loop
End If
File.WriteLine(" ")
File.WriteLine(" ")
'Bei der Anzeige einzelner Fundstellen weitere am Ende angeben:
'**************************************************************
If not Ask="b" then
'Wenn keine weiteren Fundstellen da sind:
'****************************************
If Ort1(0)=Ort1(Zahl1-1) then
File.WriteLine(" ")
File.WriteLine(" ")
File.WriteLine("Weitere Fundstellen sind nicht vorhanden !")
File.WriteLine("******************************************")
End If
'Die weiteren Fundstellen, dabei keine doppelt verwenden:
'********************************************************
If not Ort1(0)=Ort1(Zahl1-1) then
File.WriteLine(" ")
File.WriteLine(" ")
If Zwei="0" then
File.Write("Der Begriff "" "&Wort(0))
File.WriteLine(" "" findet sich in folgenden Dateien:")
File.Write("********************************")
File.WriteLine("***************************")
File.WriteLine(" ")
End If
If Zwei="1" then
File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1))
File.WriteLine(" "" stehen beide in folgenden Dateien:")
File.Write("*************************************")
File.WriteLine("*************************************")
File.WriteLine(" ")
End If
End If
End If
If Ask="b" then
File.WriteLine("Das waren folgende Dateien:")
File.WriteLine("***************************")
End If
'Alle Fundstellen werden zum Schluss aufgezählt:
'***********************************************
For i=1 to ZahlR+1
File.WriteLine(Dat(Numm(i)))
Next
'Folgendes muss sein, damit die Datei am Schluss löschbar wird:
'**************************************************************
File.Close
Set File=Nothing
'Die Meldedatei schließen, falls sie noch geöffnet sein sollte:
'**************************************************************
If Fso.FileExists(DateiM) then
Set Wmi=GetObject("Winmgmts:")
Set System=Wmi.InstancesOf("Win32_Process")
For each Process in System
If LCase(Process.name)=LCase("Notepad.exe") then
Process.Terminate (0)
End if
Next
End If
'Bei Erfolg den Abschnitt mit dem Begriff - oder allen anzeigen:
'***************************************************************
Wss.Run "Notepad """&DateiS&""" "
WScript.Sleep 2000
'Die Melde - und die Ausgabe -Datei löschen:
'*******************************************
If Fso.FileExists(DateiM) then Fso.DeleteFile DateiM
If Fso.FileExists(DateiS) then Fso.DeleteFile DateiS
'############################################################
Sub Doppel
'Die Suche des Begriff 2 (Wort(1)) in sämtlichen Zeilen(i,k):
'************************************************************
Hier2=""
Zahl2="0" 'Zahl der Fundstellen
For i=1 to DZahl
For k=1 to Ende(i)
l=1
Do until l>Len(Zeile(i,k))-Len(Wort(1))+1
If LCase(Mid(Zeile(i,k),l,Len(Wort(1))))=Wort(1) then
If Len(Hier2)>0 then Hier2=Hier2&"|"&i&","&k
If Hier2="" then Hier2=i&","&k
Zahl2=Zahl2+1 'Wie oft "Wort(1)" gefunden?
End If
l=l+1
Loop
Next
Next
'Oder Abbruch - falls Begriff 2 nicht gefunden wurde:
'****************************************************
If Hier2="" then MsgBox UV&VbCR&"Der Begriff "" "&_
Wort(1)&" "" ist nicht zu finden ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Die Aufsplittung der Fundorte in Ort2(0) usw.:
'**********************************************
Ort2=Split(Hier2,"|")
Fund=Ort2(0) '1. Fundstelle mit Wort 2
'Die Fundstellen für Wort2 werden markiert:
'******************************************
i=0
Do until i=Zahl2
Nr=Split(Ort2(i),",") 'Ort2(i) in 2 Zahlen splitten
'Wenn noch nicht markiert:
If not Right(Zeile(Nr(0),Nr(1)),5)="22222" then
Zeile(Nr(0),Nr(1))=Zeile(Nr(0),Nr(1))&" 2222222222"
End If
i=i+1
Loop
'Gefundene Datei-Nrn. (auf keinen Fall doppelte) auflisten:
'**********************************************************
Rest=Fund
k=1
Do until k=Zahl2
Nr1=Split(Ort2(k),",") 'Ort2(k) in 2 Zahlen splitten
Nr0=Split(Ort2(k-1),",") 'Ort2 davor auch!
If (Ort2(k)<>Fund and Nr1(0)<>Nr0(0)) then
Rest=Rest&"|"&Ort2(k)
End If
k=k+1
Loop
'Falls mehr als eine Fundstelle da ist:
'**************************************
Test=InStr(Rest,"|") 'Wann "Fund" zu Ende ?
If Test>0 then ' <<<<<<<<<<<<<<<<<<
Rest=Right(Rest,Len(Rest)-Test) 'Restliche Fundorte
ZahlR="1" 'Die Anzahl der restlichen Fundorte:
For i=1 to Len(Rest)
If Mid(Rest,i,1)="|" then ZahlR=1+ZahlR
Next
End If
'Name der ersten Fund - Datei:
'*****************************
ReDim Preserve Numm(1+ZahlR)
Nr=Split(Fund,",")
Numm(1)=Nr(0)
Fund=Dat(Nr(0)) '1. Datei !
'Die gemeinsamen Fundstellen für beide Begriffe suchen:
'******************************************************
If Zahl1>=Zahl2 then Zahl=Zahl1
If Zahl2>=Zahl1 then Zahl=Zahl2
Hier=""
i=0
Do until i=Zahl1
k=0
Do until k=Zahl2
Nr1=Split(Ort1(i),",")
Nr2=Split(Ort2(k),",")
If Nr1(0)=Nr2(0) then
If Hier="" then Hier=Ort1(i)
If Hier<>"" then Hier=Hier&"|"&Ort1(i)
End If
k=k+1
Loop
i=i+1
Loop
'###########################################################
'Ab hier wird alles so bezeichnet wie bei nur einem Begriff,
'damit die Ausgabe genau so erfolgt wie bei einem Begriff !!
'###########################################################
'Die Aufsplittung der gemeinsamen Fundorte in Ort1(0) usw.:
'***********************************************************
Ort1=Split(Hier,"|")
'Abbruch, falls die beiden Begriffe nicht gemeinsam auftreten:
'*************************************************************
If Hier="" then MsgBox UV&VbCR&"Die Begriffe "" "&Wort(0)&_
" "" und "" "&Wort(1)&" "" "&_
" treten nicht gemeinsam auf ! "&UV&_
VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !!
'Die Anzahl der gemeinsamen Fundorte bestimmen:
'**********************************************
Zahl1="1"
For i=1 to Len(Hier)
If Mid(Hier,i,1)="|" then Zahl1=1+Zahl1
Next
Fund=Ort1(0) 'Erster gemeinsamer Fundort
End Sub
'#############################################################
Sub WordDoc
'Den aktuellen Ordner auf "Doc" - Dateien durchsuchen:
'*****************************************************
Set Data=Fso.GetFolder(AktVerz).Files
ZahlDoc="0"
i=1
For each File in Data
ReDim Preserve Dat(i)
If LCase(Fso.GetExtensionName(File))=Endg then
Dat(i)=File
ZahlDoc=1+ZahlDoc 'Zahl der Doc-Dateien
i=i+1
End If
Next
'Die "Doc" - Dateien als "Txt" - Hilfs-Dateien neu speichern:
'************************************************************
For x=1 to ZahlDoc
'Zu Doc-Datei die Txt-Datei mit gleichem Namen festlegen:
Namen=Left(Fso.GetFileName(Dat(x)), _
Len(Fso.GetFileName(Dat(x)))-3)&"txt"
If x="1" then Const WdFormatText=2
Set WinWord=CreateObject("Word.Application")
With WinWord
.Documents.Open(Dat(x))
.ActiveDocument.SaveAs AktVerz&"\DocDoc\"&Namen,WdFormatText
.Quit
End With
'"Dat(x) als Txt-Datei aus "DocDoc" definieren:
Dat(x)=AktVerz&"\DocDoc\"&Namen
Next
End Sub
#########################################################################
>>> verz-suchen-loeschen-test.vbs <<<
'v2.4***************************************************
' File: Verz-Suchen-Loeschen-Test.VBS Ergänzung zu
' Verz-Suchen-Loeschen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Verz_Suchen_Loeschen.VBS ist Ergebnis einer Newsgroup-
' Anfrage: Auf einem Server müssen die 'Temporary Inter-
' net Files' in allen ...\user\... Verzeichnissen kom-
' plett gelöscht werden.
' Um das nicht gleich hart in einer Produktionsumbegung
' testen zu müssen, habe ich noch
' Verz_Suchen_Loeschen-Test.VBS
' geschrieben, dass diese Verzeichnisstruktur zum Test
' mal eben auf C:\ erstellt
'*******************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
UserVerz = "C:\uSer\"
UserVerz = "\\Server01\TheUser"
UserVerz = "\\Server01\c$\TheUser"
Dim User (50)
User(0) = "ing"
User(1) = "meister"
User(2) = "stift"
User(3) = "herr"
User(4) = "frau"
User(5) = "Miss"
User(6) = "Mister"
User(7) = "König"
User(8) = "Königin"
User(9) = "Knappe"
User(10) = "1ing"
User(11) = "1meister"
User(12) = "1stift"
User(13) = "1herr"
User(14) = "1frau"
User(15) = "1Miss"
User(16) = "1Mister"
User(17) = "1König"
User(18) = "1Königin"
User(19) = "1Knappe"
User(20) = "2ing"
User(21) = "2meister"
' User(22) = ""
User(22) = "2stift"
User(23) = "2herr"
User(24) = "2frau"
User(25) = "2Miss"
User(26) = "2Mister"
User(27) = "2König"
User(28) = "2Königin"
User(29) = "2Knappe"
If not (fso.FolderExists(UserVerz)) Then
FSO.CreateFolder(UserVerz)
End If
for i = 0 to 50
if User(i) = "" Then exit for
' On Error Resume Next
Txt = UserVerz & "\" & user(i) : If not FSO.FolderExists( Txt ) Then FSO.CreateFolder( Txt )
Txt = UserVerz & "\" & user(i) & "\Temporary Internet Files" : If not FSO.FolderExists( Txt ) Then FSO.CreateFolder( Txt )
Txt = UserVerz & "\" & user(i) & "\Temp" : If not FSO.FolderExists( Txt ) Then FSO.CreateFolder( Txt )
Txt = UserVerz & "\" & user(i) & "\DAT" : If not FSO.FolderExists( Txt ) Then FSO.CreateFolder( Txt )
Txt = UserVerz & "\" & user(i) & "\neues" : If not FSO.FolderExists( Txt ) Then FSO.CreateFolder( Txt )
Txt = UserVerz & "\" & user(i) & "\nur hier" : If not FSO.FolderExists( Txt ) Then FSO.CreateFolder( Txt )
On Error GoTo 0
next
MsgBox i & " Test-Verzeichnisse sind angelegt", , WScript.ScriptName
#########################################################################
>>> verz-suchen-loeschen.vbs <<<
'v2.4***************************************************
' File: Verz-Suchen-Loeschen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Skript ist Ergebnis einer Newsgroup-Anfrage: Auf einem
' Server müssen die 'Temporary Internet Files' in allen
' ...\user\... Verzeichnissen komplett gelöscht werden.
'*******************************************************
Option Explicit
Dim UserVerz, newpath, LoeschVerz
Dim i, n, index, Txt(), Text, Text1, TextX
Dim WSHShell, FSO
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
UserVerz = "C:\User"
LoeschVerz = "Temporary Internet Files"
' Temporary Internet Files
If not (fso.FolderExists(UserVerz)) Then
MsgBox UserVerz & " - Verzeichnis existiert nicht!", , WScript.ScriptName
WScript.Quit
End If
' Hole Ordner
newpath = fso.GetFolder(UserVerz)
index = 1
RecFolder index, newpath ' Hole Ordnerauflistung mit "Sub RecFolder"
For i = 1 to Ubound(Txt) ' Hole Ergebnis aus Txt(i) = Ordnerauflistung
Text = Text & Txt(i)
Next
Text1 = Split(Text, vbCRLF) ' Array Text in Zeilen aufteilen
Text = ""
n = 0
For i = 0 to Ubound(Text1)
if FSO.FolderExists(Text1(i) & "\" & LoeschVerz) then
fso.DeleteFolder(Text1(i) & "\" & LoeschVerz)
Text = Text & Text1(i) & vbCRLF
n = n +1
End If
Next
TextX = "In folgende " & n & " Verzeichnissen wurden """ & loeschVerz & """ gelöscht:" & vbCRLF & vbCRLF
TextX = TextX + Text
if not n = 0 then MsgBox TextX, , WScript.ScriptName
if n = 0 then MsgBox "Es gab keine """ & loeschVerz & """ in """ & UserVerz & """ ", , WScript.ScriptName
WScript.Quit
Sub RecFolder (idx, path)
' Autor: (c) Günter Born
'*********************************************************
' Rekursive Ordnerbearbeitung (hole Unterordner)
Dim oFolders, oSubFolder, oFolder
' Hole Folders-Auflistung
Set oFolders = fso.GetFolder(path)
Set oSubFolder = oFolders.SubFolders
Redim Preserve Txt(idx) ' redim String-Array
For Each oFolder in oSubFolder ' alle Ordner
Txt(idx) = Txt(idx) & path & "\" & oFolder.name & vbCRLF
' Unterordner rekursiv suchen
Call RecFolder (idx+1, path & "\" & oFolder.name)
Next
Set oFolders = Nothing ' Variable freigeben
Set oSubFolder = Nothing
End Sub
#########################################################################
>>> verz-suchen-loeschen2.vbs <<<
'v5.8***************************************************
' File: Verz-Suchen-Loeschen.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Skript ist Ergebnis einer Newsgroup-Anfrage: Auf einem
' Server müssen die 'Temporary Internet Files' in allen
' ...\user\... Verzeichnissen komplett gelöscht werden.
'*******************************************************
Option Explicit
Dim UserVerz, Pfad, LoeschVerz
Dim i, n, z, Txt
Dim WSHShell, fso, oFolders, oSubFolder, VerzX
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
UserVerz = "C:\User"
UserVerz = "\\Server01\TheUser"
UserVerz = "\\Server01\c$\TheUser"
LoeschVerz = "Temporary Internet Files"
If not (fso.FolderExists(UserVerz)) Then
MsgBox UserVerz & " - Verzeichnis existiert nicht!", , WScript.ScriptName
WScript.Quit
End If
' Hole Ordner
Pfad = fso.GetFolder(UserVerz) ' Fals eine Datei statt eines Verzeichnisses übergeben wurde
' Verzeichnisliste an Array übergeben ' aus http://dieseyer.de/scr-html/datei-verzeichnis-liste.html
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' siehe auch http://dieseyer.de/scr-fu/datei-verzeichnis-liste-fu.html
i = 0
Set oFolders = fso.GetFolder( Pfad )
Set oSubFolder = oFolders.SubFolders
For Each VerzX In oSubFolder
ReDim Preserve Verz(i)
' Verz(i) = VerzX.Name
Verz(i) = VerzX.Path
i = i + 1
Next
Set oSubFolder = nothing
Set oFolders = nothing
' Array abarbeiten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
n = 0 : z = 0
If i > 0 then ' wenn es Verzeichnis(se) gibt
For i = LBound( Verz ) to UBound( Verz )
If fso.FolderExists( Verz(i) & "\" & LoeschVerz ) Then
On Error Resume Next
n = n + 1 : fso.DeleteFolder( Verz(i) & "\" & LoeschVerz ) ' Verzeichnis soll gelöscht werden
On Error GoTo 0
If not fso.FolderExists( Verz(i) & "\" & LoeschVerz ) Then
z = z + 1 ' Verzeichnis lies sich löschen
End If
Else
End If
Next
End If
Txt = "Es wurden in " & UBound( Verz )+1 & " Userverzeichnissen " & "unterhalb von """ & Pfad & """" & vbCRLF
Txt = Txt & n & " mal " & """" & LoeschVerz & """ gefunden, von denen " & z & " gelöscht werden konnten."
if not UBound( Verz ) = 0 then MsgBox Txt, , WScript.ScriptName
if UBound( Verz ) = 0 then MsgBox "Es gab keine """ & loeschVerz & """ in """ & UserVerz & """ ", , WScript.ScriptName
WScript.Quit
#########################################################################
>>> verzeichnisaltdelete.vbs <<<
'v3.7*****************************************************
' File: VerzeichnisAltDelete.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Löscht alle Verzeichnisse, die ab einem bestimmten Datum
'*********************************************************
Option Explicit
Dim Pfad, Alter
Pfad = "d:\setup"
Pfad = "." ' Verzeichnis, in dem sich das Skript befindet, Skript wird also auch gelöscht
Pfad = "c:\temp"
Alter = 365 ' Verzeichnisse, die vor xxx Tagen angelegt wurden
MsgBox AlteVerzLoeschen (Pfad, Alter ) 'Function Aufruf und Ergebnisanzeige
AlteVerzLoeschen "c:\temp", 100 'Function Aufruf OHNE Ergebnisanzeige
' ~~~~~~
WScript.Quit
'*********************************************************
Function AlteVerzLoeschen (Pfad, Alter) ' Anfang
'*********************************************************
Dim fso, Txt, i, oSubFolder
Alter = FormatDateTime( now() - Alter ,2)
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists( Pfad ) then
MsgBox UCase(Pfad) & " existiert nicht!", , WScript.ScriptName
Exit Function
End If
AlteVerzLoeschen = "In " & UCase( Pfad ) & " wurden vor dem " & Alter & " angelegte Verzeichnisse gelöscht." & vbCRLF & vbCRLF
Set oSubFolder = fso.GetFolder( Pfad ).SubFolders
For Each i In oSubFolder
if DateDiff("d" , i.DateLastModified, Alter) > 0 then ' vor dem Alter geänderte Verzeichnisse
Txt = i.Path ' nach dem Löschen von i.Path ist auch i.Path gelöscht
AlteVerzLoeschen = AlteVerzLoeschen & i.Name & " " & vbTab & FormatDateTime( i.DateLastModified ,2)
On Error Resume Next
fso.DeleteFolder Txt, True
On Error GoTo 0
If not fso.FolderExists( Txt ) Then
AlteVerzLoeschen = AlteVerzLoeschen & vbCRLF
Else
AlteVerzLoeschen = AlteVerzLoeschen & " nicht gelöscht." & vbCRLF
End if
End If
Next
Set fso = nothing
Set oSubFolder = nothing
End Function ' AlteVerzLoeschen
#########################################################################
>>> w2krestart.vbs <<<
'v2.5*****************************************************
' File: W2kRestart.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Startet Win2k-System neu; erstellt ein Protokoll
' Startet nicht als Dienst; es muss ein geöffneter Desktop
' vorhanden sein
'*********************************************************
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".Log", 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
TextX = now & vbTab & WScript.ScriptName & " wird jetzt gestratet."
FileOut.WriteLine (TextX)
FileOut.Close
Set FileOut = Nothing ' Datei schließen
WshShell.sendkeys "^{ESC}" ' entspr. <Winows> - Taste
WshShell.sendkeys "{ESC}" ' Abbrechen - ak. Applikation ist jetzt der Desktop
WshShell.sendkeys "%{F4}" ' <Alt-F4> für den Desktop
' WshShell.sendkeys "n" ' n für Neustart deutsche NT4-Version
' WshShell.sendkeys "r" ' r für Restart englische W2k-Version
WshShell.sendkeys "n" ' n für Neustart deutsche W2k-Version
' *** nächste Zeile frei geben
' WshShell.sendkeys "{Enter}"
#########################################################################
>>> w2kshutdown.vbs <<<
'v2.5*****************************************************
' File: W2kShutDown.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Fährt Win2k-System herrunter; erstellt ein Protokoll
' Startet nicht als Dienst; es muss ein geöffneter Desktop
' vorhanden sein
'*********************************************************
set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile(WScript.ScriptName & ".Log", 8, true) ' Datei zum Erweitern öffnen (notfals anlegen)
TextX = now & vbTab & WScript.ScriptName & " wird jetzt gestratet."
FileOut.WriteLine (TextX)
FileOut.Close
Set FileOut = Nothing ' Datei schließen
WshShell.sendkeys "^{ESC}" ' entspr. <Winows> - Taste
WshShell.sendkeys "{ESC}" ' Abbrechen - ak. Applikation ist jetzt der Desktop
WshShell.sendkeys "%{F4}" ' <Alt-F4> für den Desktop
' WshShell.sendkeys "c" ' c für Comp. Herrunter.. deutsche NT4-Version
' WshShell.sendkeys "s" ' s für ShutDown englische W2k-Version
WshShell.sendkeys "h" ' h für Herrunter.. deutsche W2k-Version
' *** nächste Zeile frei geben
' WshShell.sendkeys "{Enter}"
#########################################################################
>>> wait.vbs <<<
'*** v9.7 *** www.dieseyer.de ******************************
'
' Datei: wait.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Skript sollte in einem über PATH erreichbaren Verzeichnis
' liegen (z.B. c:\windows\system32\) und kann dann in einer
' .bat bzw. .cmd-Datei aufgerufen werden:
' wait.vbs 10
' läßt die Abarbeitung (etwa) 10 Sekunden ruhen.
' Wird kein Parameter übergeben oder ist dieser kleiner als,
' 0,1 oder 0.1. wird das Skript für 1/10 Sek. angehalten.
' Nachkommastellen weren entfernt (Ausser bei 0.1).
'
' Werden mehr als ein Parameter übergeben, wird versucht,
' diese nach Ablauf der Zeit per WSHShell.Run zu starten.
' "wait.vbs 99 taskmgr.exe" startet nach 99s den Taskmanager
'
' .lnk-Dateien lassen sich nicht starten.
' Parameter können an zu startende Programme nicht
' übergeben werden.
'
'***********************************************************
Option Explicit
Dim Progr, Zeit, i, oArgs
set oArgs = Wscript.Arguments
' hole alle Argumente
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
If i = 0 Then Zeit = oArgs.item(i)
If i = 1 Then Progr = Progr & oArgs.item(i)
If i > 1 Then Progr = Progr & " " & oArgs.item(i)
Next
If InStr( Zeit, "." ) Then Zeit = Left( Zeit, InStr( Zeit, "." ) -1 )
If InStr( Zeit, "," ) Then Zeit = Left( Zeit, InStr( Zeit, "," ) -1 )
' Nachkomma- / Nachpunkt-Stellen entfernen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next ' keine Unterbrechung bei Fehler
If Zeit < 0.1 Then Zeit = 0.1
Zeit = Zeit / 10*10 ' das ist so etwas ähnliches wie eine Typ-Wandlung
If Zeit > 60*60*24*7 Then Zeit = 60*60*24*7 ' 60*60*24*7 ist eine Woche
On Error GoTo 0
' ermittelte Zeit warten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Sleep Zeit*1000 ' statt Millisekunden
' MsgBox """" & Progr & """" & vbCRLF & Zeit & " Sekunde(n) sind um.", , WScript.ScriptName
' Wurde kein zu startendes Programm (als Parameter) übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Progr = "" Then WScript.Quit
' prüfen, ob erhaltener Parameter als Datei gefunden wird
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If CreateObject("Scripting.FileSystemObject").FileExists( Progr ) Then
Progr = Trim( Progr ) ' Leerzeichen am Anfang und am Ende entfernen
Progr = """" & Progr & """"
' Progr = inputBox( "'" & Progr & "'", , Progr )
WScript.CreateObject("WScript.Shell").Run Progr
Else
MsgBox vbTab & "! ! ! F E H L E R ! ! !" & vbCRLF & vbCRLF & "Folgendes Programm soll gestartet werden, existiert aber nicht:" & vbCRLF & vbCRLF & Progr, vbCritical + 4096, "71 :: " & WScript.ScriptName
End If
' MsgBox "! ! ! E N D E ! ! !", vbInformation + 4096, "74 :: " & WScript.ScriptName
WScript.Quit
#########################################################################
>>> wav-to-mp3.vbs <<<
'v4.2*****************************************************
' File: wav-to-mp3.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Sucht im Zielverz. nach WAV-Dateien und wandelt diese
' mit LAME (http://www.mp3dev.org) in MP3-Dateien um,
' wenn es noch keine MP3-Datei mit selbigen Namen gibt.
' Anschließend werden die MP3's zur Kontrolle angepielt,
' zu denen WAV's existieren. Nach dem Schließen des MP3-
' Players wird gefragt, ob die WAV-Datei gleichen Namens
' gelöscht werden soll.
' Die MP3-Tag's werden richtig gesetzt, wenn die Verzeich-
' nisse den Namen des Interpreten haben - die WAV-Dateien
' tragen in ihrem Namen den Song-Titel.
'*********************************************************
Option Explicit
Dim Song, Interpret
Dim Text, Text1, Text2, index, Txt(), i, i1, i2, newpath
Dim fso, fo, fi, FileOut
Dim LameExe, LameParam, ZielVerz, Ziel, Quelle, WSHShell
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Text = ""
LameExe = "C:\#DasDing\lame.exe"
ZielVerz = "C:\#DasDing"
ZielVerz = fso.GetFolder(".")
LameExe = ZielVerz & "\lame.exe"
If not fso.FileExists(LameExe) Then
MsgBox LameExe & " existiert nicht!", , WScript.ScriptName
WScript.Quit
End If
If not fso.FolderExists(ZielVerz) Then
MsgBox ZielVerz & " - Verzeichnis existiert nicht!", , WScript.ScriptName
WScript.Quit
End If
RecFolder 1, Zielverz ' Hole Ordnerauflistung mit "Sub RecFolder"
For i = LBound(Txt) to UBound(Txt) ' Hole Ergebnis aus Txt(i) = Ordnerauflistung
Text = Text & Txt(i)
Next
Text1 = Split(Text, vbCRLF) ' Array Text in Zeilen aufteilen
mp3Erstellen
' wavDelete
WScript.Quit
' Autor: (c) Günter Born
'*********************************************************
Sub RecFolder (idx, path)
' Rekursive Ordnerbearbeitung (hole Unterordner)
Dim oFolders, oSubFolder, oFolder
' Hole Folders-Auflistung
Set oFolders = fso.GetFolder(path)
Set oSubFolder = oFolders.SubFolders
Redim Preserve Txt(idx) ' redim String-Array
For Each oFolder in oSubFolder ' alle Ordner
Txt(idx) = Txt(idx) & path & "\" & oFolder.name & vbCRLF
' Unterordner rekursiv suchen
Call RecFolder (idx+1, path & "\" & oFolder.name)
Next
Set oFolders = Nothing ' Variable freigeben
Set oSubFolder = Nothing
End Sub
Sub wavDelete
' wenn .wav-Datei und .mp3-Datei mit gleichem Namen existiert,
' wird die .mp3-Datei zur Kontrolle abgespielt und vorgeschlagen,
' die .wav-Datei zu löschen
'*********************************************************
i2 = 0
Text = ""
Text2 = "Im Folgenden wird jede mp3-Datei abgespielt, zu der eine wav-Datei" & vbCRLF
Text2 = Text2 & "mit gleichem Namen existiert. Nach dem Schließen des Players wird " & vbCRLF
Text2 = Text2 & "gefragt, ob die entsprechende wav-Datei gelöscht werden soll"
MsgBox Text2, , WScript.ScriptName
For i = LBound(Text1) to UBound(Text1) ' Hole Ergebnis aus Text1(i)
' For i = 1 to Ubound(Text1) -1
Set fo = fso.GetFolder(Text1(i))
Set fi = fo.Files ' Datei-Auflistung holen
For Each i1 In fi ' hole alle Dateien
if Ucase(Right(i1.name,4)) = ".WAV" then ' hole nur WAV - Dateien
Quelle = Text1(i) & "\" & i1.Name
Ziel = Mid(Quelle, 1, Len(Quelle) -4) & ".mp3"
if fso.FileExists(Quelle) AND fso.FileExists(Ziel) then ' wenn es zu einer .wav-datei
' eine .mp3-Datei gibt
i2 = i2+1
WSHShell.Run """" & Ziel & """", , True
Text2 = "Abgespielt wurde" & vbTab & vbTab & Ziel & vbCRLF & vbCRLF
Text2 = Text2 & "Soll " & vbTab & vbTab & Quelle & vbCRLF & vbCRLF
Text2 = Text2 & "gelöscht werden? "
Text2 = MsgBox (Text2, 4 + 256, WScript.ScriptName)
If Text2 = vbYes then ' wurde Yes gedrückt,
fso.DeleteFile(Quelle), True ' wird diese gelöscht
' WScript.Sleep 500 ' 500 Millisekunden warten
if fso.FileExists(Quelle) then MsgBox "ACHTUNG!" & vbCRLF & vbCRLF & Quelle & " konnte nicht gelöscht werden!"
if fso.FileExists(Quelle) then Text = Text & "(" & i2 & ") ungelöscht: " & vbTab & "..." & Mid(Quelle,Len(ZielVerz)+1) & vbCRLF
if not fso.FileExists(Quelle) then Text = Text & "(" & i2 & ") gelöscht: " & vbTab & "..." & Mid(Quelle,Len(ZielVerz)+1) & vbCRLF
Else
Text = Text & "(" & i2 & ") ungelöscht: " & vbTab & "..." & Mid(Quelle,Len(ZielVerz)+1) & vbCRLF
End If
End If
End If
Next
Set fo = Nothing ' Datei schließen
Next
If i2 = 0 then MsgBox "In " & newpath & "\... wurden keine mp3-Dateien gefunden, von denen es auch eine wav-Datei gibt.", , WScript.ScriptName
If i2 > 0 then MsgBox "Ordner " & newpath & "\..." & vbCRLF & vbCRLF & Text, vbOkonly + vbInformation, WScript.ScriptName
End Sub
Sub mp3Erstellen
' zu jeder .wav-Dateien eine .mp3-Dateien erstellen
'*********************************************************
i2 = 0
Text = ""
For i = LBound(Text1) to UBound(Text1)-1 ' Hole Ergebnis aus Text1(i)
' For i = 1 to Ubound(Text1) -1 ' zeilenweise (aus Text1)
Set fo = fso.GetFolder(Text1(i)) ' für jedes Verzeichnis
Set fi = fo.Files ' Datei-Listung holen
For Each i1 In fi ' hole alle Dateien aus Datei-Liste
if Ucase(Right(i1.name, 4)) = ".WAV" then ' hole nur WAV - Dateien
Quelle = Text1(i) & "\" & i1.Name
Song = Mid(i1.name, 1, Len(i1.name) -4)
Interpret = Mid(Text1(i), Len(ZielVerz) + 2)
Ziel = ZielVerz & "\" & Interpret & "\" & Song & ".mp3"
Ziel = Mid(Quelle, 1, Len(Quelle) -4) & ".mp3"
if fso.FileExists(Ziel) then ' wenn es zu einer .wav-datei eine
if fso.GetFile(Ziel).Size = 0 then ' 0 Byte große .mp3-Datei gibt
fso.DeleteFile(Ziel), True ' wird diese gelöscht
WSHShell.Popup "0 Byte große Datei " & Ziel & " wurde gelöscht", 3, WScript.ScriptName
End If
End If
if not fso.FileExists(Ziel) then ' wenn es von der .WAV- noch keine .mp3-Datei gibt
if not fso.GetFile(Quelle).Size/5 < fso.GetDrive(Left(Quelle,3)).AvailableSpace then
MsgBox "Auf " & ZielVerz & " steht nicht genügend Platz zur Verfügung!", , WScript.ScriptName
Exit Sub ' wenn weniger als 20% der Größe der Quelle-Datei auf
End If ' dem Ziellaufwerk frei ist - Abbruch
LameParam = " """ & Quelle & """ """ & Ziel & """ -b 128 "
LameParam = " """ & Quelle & """ """ & Ziel & """ -b 96 "
LameParam = LameParam & " --tt """ & Song & """ --ta """ & Interpret & """"
' MsgBox LameExe & LameParam
WSHShell.Run LameExe & LameParam , , True
i2 = i2+1
Text = Text & "(" & i2 & ") " & vbTab & "..." & Mid(Ziel,Len(ZielVerz)+1) & vbCRLF
End If
End If
Next
Set fo = Nothing ' Datei schließen
Next
If i2 = 0 then MsgBox "In " & newpath & "\... wurden keine wav-Dateien zum Wandeln in mp3 gefunden.", , WScript.ScriptName
If i2 > 0 then MsgBox "Folgende Dateien wurden in " & ZielVerz & "\... erstellt " & vbCRLF & Text, vbOkonly + vbInformation, WScript.ScriptName
End Sub
#########################################################################
>>> WIM-BuR.hta <<<
<html>
<head>
<!--
'*** v10.B *** www.dieseyer.de *****************************
'
' Datei: WIM-BuR.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Eine kurze Beschreibung wird beim Start des Hta angezeigt,
' bevor es irgend etwas 'macht'.
'
'***********************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
-->
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="WIM-BuR"
SINGLEINSTANCE="yes"
MAXIMIZEBUTTON="no"
ICON="WIM-BuR.ico"
>
<title>WIM - Backup und Restore</title>
<style type="text/css">
html, body { background-color: #116; color: #ec0; font-weight: normal; font-size:9pt; line-height=1.1em; font-family: verdana,arial,sans-serif,Microsoft Sans Serif,times }
.InputStart{ background-color: #116; color: #ec0; font-weight: bold; border: 2px solid #339; margin-left: 3px; width: 25px; height: 12px; }
.InputNr{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 0px; width: 2.5em; height: 22px; }
.WIMAanzWahl1{ background-color: #116; color: #f60; font-weight: bold; font-size: 7pt; margin-left: 0px; width: 605px; height: 22px; }
.WIMAanzWahl2{ background-color: #116; color: #0C0; font-weight: bold; font-size: 7pt; margin-left: 0px; width: 605px; height: 22px; }
.InputInst{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 0px; width: 0.9em; height: 22px; }
.InputMini{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 0px; width: 0; height: 0; }
.InputExpert{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 09px; width: 180px; height: 22px; }
.InputSonst{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 09px; width: 80px; height: 22px; }
.InputMenu { background-color: #116; color: #ec0; font-weight: bold; border: 2px solid #339; margin-left: 03px; width: 125px; height: 26px; }
div#Inhalt { clear: both; }
div#Inhalt span { text-decoration: underline; }
a { color: #ec0; text-decoration: underline; }
a:hover { background-color: #11F; }
</style>
</head>
<script language="VBscript">
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const ZeitTest = "-Ja"
Const KeineLog = "-JA"
Dim ProgrOK : ProgrOK = vbFalse ' vbTrue, wenn ProgrExe erreichbar ist
Dim ProgrExe : ProgrExe = "IMAGEX.EXE"
Dim ProgrPara, ProgrVersion, LfdKey, GottModus
ProgrPara = "/COMPRESS maximum /CHECK /VERIF"
ProgrPara = "/COMPRESS maximum /VERIFY"
ProgrPara = "/COMPRESS maximum"
' "maximum" spart im Durchschnitt 10% Platz, dauert
' aber häufig bis zu drei Mal so lange wie "fast"
ProgrPara = "/COMPRESS fast /CHECK /VERIFY"
ProgrPara = "/COMPRESS fast /VERIFY"
ProgrPara = "/COMPRESS fast"
Dim WIMDateiDatum
Dim WIMGewaehlt : WIMGewaehlt = "Aktuell ist kein WIM ausgewählt."
' : WIMGewaehlt = "I:\Test-x.Wim"
Dim DatenQuelle : DatenQuelle = ""
' : DatenQuelle = "D:\dieseyer.de"
Dim DatenZiel : DatenZiel = ""
' : DatenZiel = "C:\summe.wim"
' : DatenZiel = "C:\xxxx"
Dim Titel, HtaSelbst, HtaDatum, AktVerz
Dim TastTaste
Dim MenueAkt ' speichert den zu letzt angewählte Menü-Reiter
Dim VOW ' speichert Datei- / Verzeichnis-Auswahl für Restore (in Verzeichnise oder in WIM)
Dim TempVerz, XMLDatei, XSLDatei, CMDPfad, HTMDatei, DirDatei, HTMLTxt
Dim BuRInfoMenue, BuRBackupMenue, BuRRestoreMenue, BuRDeleteMenue, BuRWIMInfoMenue
Dim LogDatei
ReDim Preserve zwTxt( 2, 0 ) ' die Prozedur zwLog speichert die Log-Informationen, bis der Name der Log-Datei festgelegt ist
Dim Tst
Dim ProgrVerz : ProgrVerz = ""
Tst = CreateObject("WScript.Network").ComputerName
If InStr( UCase( Tst ), "MININT" ) = 1 Then ProgrVerz = "MININT" ' bei WinPE
If InStr( UCase( Tst ), "MINWINPC" ) = 1 Then ProgrVerz = "MININT" ' bei WinPE
If ProgrVerz = "" Then ProgrVerz = CreateObject("Shell.Application").Namespace( 38 ).Self.Path ' ergibt C:\Programme
Const DSProgr = "dieseyer.de"
' MsgBox "ProgrVerz: """ & ProgrVerz & """" & vbCRLF & "ProgrPara: " & ProgrPara, , "0107 :: "
'***********************************************************
Sub zwLog( Txt, Farb )
'***********************************************************
Dim i : i = UBound( zwTxt, 2 ) + 1
If Len( zwTxt( 0, 0 ) ) = 0 AND Len( zwTxt( 1, 0 ) ) = 0 Then i = 0
ReDim Preserve zwTxt( 2, i ) : zwTxt( 0, i ) = Txt : zwTxt( 1, i ) = Farb
End Sub ' zwLog( Txt )
'***********************************************************
Sub LogSchreibenAnzeigen()
'***********************************************************
Dim i
For i = LBound( zwTxt, 2 ) to UBound( zwTxt, 2 )
Trace32Log zwTxt( 0, i ), zwTxt( 1, i )
Next
End Sub ' LogSchreibenAnzeigen()
'***********************************************************
Function BeimLaden() ' ruft einige Routinen auf
'***********************************************************
On Error Resume Next
window.moveto 0, 0
On Error Goto 0
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tst
Titel = oHTA.APPLICATIONNAME
' Call zwLog( "-", 0 ) ' erstellt neue LogDatei
' Call zwLog( " ", 1 ) ' fügt Leerzeile in LogDatei ein
zwLog " ", 1 ' fügt Leerzeile in LogDatei ein
zwLog "0143 :: Start " & Titel, 1
HtaSelbst = oHTA.CommandLine
zwLog "0146 :: Erhaltene Parameter: " & HtaSelbst, 1
Tst = InStr( HtaSelbst, """ """ )
' MsgBox ">" & HtaSelbst & "<", , "0148 :: " & Titel & Tst
If Tst > 10 Then
WIMGewaehlt = Mid( HtaSelbst, Tst )
WIMGewaehlt = Replace( WIMGewaehlt, """ ", "" )
WIMGewaehlt = Replace( WIMGewaehlt, """", "" )
HtaSelbst = Mid( HtaSelbst, 1, Tst )
zwLog "0154 :: WIMGewaehlt (als Parameter erhalten): " & WIMGewaehlt, 1
End If
' MsgBox "HtaSelbst >" & HtaSelbst & "<" & vbCRLF & "WIMGewaehlt >" & WIMGewaehlt & "<", , "0158 :: " & Titel
HtaSelbst = Replace( HtaSelbst, """ ", "" )
HtaSelbst = Replace( HtaSelbst, """", "" )
zwLog "0161 :: HtaSelbst: " & HtaSelbst, 1
' MsgBox ">" & HtaSelbst & "<", , "0162 :: " & Titel
' Dateitype .WIM registrieren - nur unter WinPE
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If ProgrVerz = "MININT" AND InStr( UCase( HtaSelbst ), "\" & UCase( DSProgr ) & "\" ) = 0 Then DateiTypRegistrieren "wim", HtaSelbst
HtaDatum = fso.GetFile( HtaSelbst ).DateLastModified
zwLog "0168 :: HtaDatum: " & HtaDatum, 1
' MsgBox ">" & HtaDatum & "<", , "0169 :: " & Titel
AktVerz = fso.GetParentFolderName( HtaSelbst ) ' : MsgBox "AktVerz: " & AktVerz, , "0171 :: "
AktVerz = Replace( AktVerz, """", "" ) ' : MsgBox "AktVerz: " & AktVerz, , "0172 :: "
zwLog "0173 :: AktVerz: " & AktVerz, 1
LogDatei = Replace( HtaSelbst, fso.GetExtensionName( HtaSelbst ), "log" )
zwLog "0176 :: LogDatei: " & LogDatei, 1
zwLog "0177 :: LogDatei wird jetzt geschrieben . . . ", 1
' MsgBox "LogDatei: " & LogDatei, , "0178 :: " & Titel
Call LogSchreibenAnzeigen() ' : CreateObject("WScript.Shell").Run LogDatei, , False
' Das Icon gibts nur bei einer Installation
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = LCase( ProgrVerz & "\" & DSProgr & "\" )
If InStr( LCase( HtaSelbst ), Tst ) = 1 Then
Tst = ProgrVerz & "\" & DSProgr & "\" & Titel & ".ico"
Trace32Log "0186 :: Icon-Datei soll erstellt werden: " & Tst, 1
If not fso.FileExists( Tst ) Then Call IcoAusHexDaten( Tst, "mm" )
Trace32Log "0188 :: Icon-Datei ist erstellt: " & Tst, 1
End If
Call BuRMenue()
Call WIMBuRMenu()
Call WIMBuRInfo()
Tst = HtaSelbst & " (vom " & HtaDatum & "; " & CreateObject("Scripting.FileSystemObject").GetFile( HtaSelbst ).Size & ")"
window.setTimeout "HtaInfoZeigen('" & "0196 :: " & Tst & "')", 0 * 333
' window.setTimeout "HtaInfoZeigen('" & now() & "')", 7 * 333
window.setTimeout "HtaInfoZeigen(' ')", 4 * 333
' Umgebung
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "WIMBuRDateien()", 1 * 333
' Erreichbarkeit des Programms IMAGEX.EXE prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "ProgrExeErreichbar()", 2 * 333
window.setTimeout "ProgrExeVersion()", 5 * 333
If InStr( WIMGewaehlt, "\\" ) = 1 OR InStr( WIMGewaehlt, ":\" ) = 2 Then
Trace32Log "0212 :: Anzeige wird zeitverzögert auf 'Informations' umgeschaltet.", 1
window.setTimeout "MenueAkt = ""WIMINFO""", 3 * 333
window.setTimeout "WIMBuRMenu()", 4 * 333
' MsgBox "0215 :: ", , "0215 :: " & Titel
Else
' MsgBox "0217 :: ", , "0217 :: " & Titel
End If
' MsgBox Replace( oHTA.CommandLine, """", "" ) & vbCRLF & ProgrVerz & "\" & DSProgr, , "0220 :: "
' fso.CopyFile Replace( oHTA.CommandLine, """", "" ), ProgrVerz & "\" & DSProgr : MsgBox "Port", , "0221 :: "
Trace32Log "0223 :: Beendet 'Function BeimLaden()'", 1
End Function ' BeimLaden()
'***********************************************************
Sub window_onbeforeunload
'***********************************************************
' window.event.returnValue = "> > > > > Mit dem Schließen dieser Anwendung wird das Programm gestartet! < < < < <"
' sollte [F5] (116) gedrückt worden sein (beendet das HTA und lädt es neu)
If TastTaste = 116 Then Exit Sub
Trace32Log "0234 :: Wird (normal) beendet: " & HtaSelbst, 1
End Sub ' window_onbeforeunload
'***********************************************************
Sub document_onKeyDown
'***********************************************************
TastTaste = window.event.keyCode
' Trace32Log "0242 :: Betätigte Taste: '" & TastTaste & "'", 1
' If TastTaste = 13 Then Call neuesEnde()
End Sub
'***********************************************************
Sub HtaInfoZeigen( Txt )
'***********************************************************
On Error Resume Next
document.all.HtaInfo.innerHTML = Txt
On Error Goto 0
End Sub ' HtaInfoZeigen( Txt )
'***********************************************************
Sub WIMBuRDateien()
'***********************************************************
Trace32Log "0259 :: Anfang 'Sub WIMBuRDateien()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt
TempVerz = UserTempVerz() & "\" ' : MsgBox "UserTempVerz: '" & TempVerz & "'", , "0262 :: "
If not fso.FolderExists( TempVerz ) Then fso.CreateFolder( TempVerz ) ' : MsgBox "Verz. erstellt: '" & TempVerz & "'", , "0263 :: "
XMLDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".xml"
XSLDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".xsl"
CMDPfad = TempVerz & fso.GetBaseName( HtaSelbst )
HTMDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".html"
DirDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".dir"
Trace32Log "0270 :: WIM-BuR - Umgebung:", 1
Trace32Log "0271 :: TempVerz: " & TempVerz, 1
Trace32Log "0272 :: XMLDatei: " & XMLDatei, 1
Trace32Log "0273 :: XSLDatei: " & XSLDatei, 1
Trace32Log "0274 :: CMDPfad: " & CMDPfad, 1
Trace32Log "0275 :: HTMDatei: " & HTMDatei, 1
Trace32Log "0276 :: DirDatei: " & DirDatei, 1
Txt = ""
Txt = Txt & vbCRLF & "HtaSelbst: " & HtaSelbst
Txt = Txt & vbCRLF & "AktVerz: " & AktVerz
Txt = Txt & vbCRLF & "TempVerz: " & TempVerz
Txt = Txt & vbCRLF & "XMLDatei: " & XMLDatei
Txt = Txt & vbCRLF & "XSLDatei: " & XSLDatei
Txt = Txt & vbCRLF & "CMDPfad: " & CMDPfad
Txt = Txt & vbCRLF & "HTMDatei: " & HTMDatei
Txt = Txt & vbCRLF & "DirDatei: " & DirDatei
' MsgBox Txt, , "0287 :: " & Titel
Trace32Log "0289 :: Beendet 'Sub WIMBuRDateien()'", 1
End Sub ' WIMBuRDateien()
'***********************************************************
Sub BuRMenue
'***********************************************************
Trace32Log "0297 :: Anfang 'Sub BuRMenue'", 1
Dim T
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 128px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 384px; height: 32px; top: -2px; left: 128px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -258px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRBackupMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 46px; left: 11px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 513px; height: 32px; top: -2px; left: 127px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -129px; border: 2px solid #dd0; border-top: none; padding: 13px; "" >"
BuRInfoMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 258px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 256px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 256px; height: 32px; top: -2px; left: 128px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -386px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRRestoreMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 386px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 384px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 128px; height: 32px; top: -2px; left: 128px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -514px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRDeleteMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 514px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 512px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 30px; left: -514px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRWIMInfoMenue = T : T = ""
Trace32Log "0328 :: Beendet 'Sub BuRMenue'", 1
End Sub ' BuRMenue
'***********************************************************
Sub ProgrExeVersion()
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' If not ProgrExeErreichbar = vbTrue Then window.setTimeout "ProgrExeVersion()", 5 * 333 : Exit Sub
If not ProgrOK = vbTrue Then window.setTimeout "ProgrExeVersion()", 5 * 333 : Exit Sub
If not fso.FileExists( ProgrExe ) Then window.setTimeout "ProgrExeVersion()", 5 * 333 : Exit Sub
ProgrVersion = "(v" & fso.GetFileVersion( ProgrExe ) & ")"
' "ImageX.exe " & ProgrVersion & " -"
End Sub ' ProgrExeVersion()
'***********************************************************
Function ProgrExeErreichbar
'***********************************************************
Trace32Log "0349 :: Anfang 'Function ProgrExeErreichbar'", 1
Trace32Log "0350 :: Aktuelle ProgrExe: " & ProgrExe, 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim Txt, Tst, errTst
' ProgrExe muss kompletten Pfad enthalten (für CmdBef)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = TempVerz & ProgrExe : ' MsgBox Txt, , "0358 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0359 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0360 :: ProgrExe fehlt: " & Txt, 2
Txt = AktVerz & "\" & ProgrExe : ' MsgBox Txt, , "0362 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0363 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0364 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\" & ProgrExe : ' MsgBox Txt, , "0366 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0367 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0368 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\System32\" & ProgrExe : ' MsgBox Txt, , "0370 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0371 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0372 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\SysWOW64\" & ProgrExe : ' MsgBox Txt, , "0374 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0375 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0376 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\SysWOW64\" & ProgrExe : ' MsgBox Txt, , "0378 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0379 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0380 :: ProgrExe fehlt: " & Txt, 2
' 0| C:\Windows
Txt = fso.GetSpecialFolder( 0 ) & "\" & ProgrExe : ' MsgBox Txt, , "0383 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0384 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0385 :: ProgrExe fehlt: " & Txt, 2
' 1| C:\Windows\System32
Txt = fso.GetSpecialFolder( 1 ) & "\" & ProgrExe : ' MsgBox Txt, , "0388 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0389 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0390 :: ProgrExe fehlt: " & Txt, 2
' 2| C:\Users\[UserName]\AppData\Local\Temp
Txt = fso.GetSpecialFolder( 2 ) & "\" & ProgrExe : ' MsgBox Txt, , "0393 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0394 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0395 :: ProgrExe fehlt: " & Txt, 2
' Suchen-Dialog, weil imagex.exe nicht gefunden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0400 :: " & ProgrExe & " nicht gefunden . . .", 1
Txt = vbCRLF & vbCRLF & "Programm kann nicht gestartet werden bzw. ist nicht erreichbar: " & vbCRLF & vbCRLF & vbTab & ProgrExe & vbCRLF & vbCRLF & "Soll der Datei-Suchen-Dialog geöffnet werden?"
Tst = MsgBox( Txt, vbQuestion + vbYesNo, "0402 :: " & Titel )
If Tst = vbYes Then
Trace32Log "0404 :: Suchen-Dialog wird geöffnet . . .", 1
Txt = BFFVerzDateitype( AktVerz, "exe" )
If Txt = "EXIT" Then Exit Function
' Txt = ChooseFile( )
Tst = InStrRev( Txt, "\" )
If Tst > 0 Then Tst = UCase( Mid( Txt, Tst + 1 ) )
If ProgrExe = Tst Then
ProgrExe = Txt
Trace32Log "0412 :: Neue ProgrExe: " & ProgrExe, 1
Txt = RemoteWinDir( "." ) & "\System32\" & Tst
ProgrExeErreichbar = vbTrue
ProgrOK = vbTrue
' document.all.InfoTxt.innerHTML = "0416 :: " & "vbTrue" & " " & ProgrExe
Tst = MsgBox( ProgrExe & vbCRLF & vbCRLF & "kopieren nach:" & vbCRLF & vbCRLF & Txt, vbQuestion + vbYesNo, "0417 :: " & Titel )
If Tst = vbYes Then
Trace32Log "0419 :: Datei kopieren (von..nach)", 1
Trace32Log "0420 :: " & ProgrExe, 1
Trace32Log "0421 :: " & Txt, 1
On Error Resume Next
fso.CopyFile ProgrExe, Txt, True
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
' MsgBox errTst, , "0427 :: "
If Len( errTst ) > 4 Then
Trace32Log "0429 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = errTst
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Die Datei """ & Txt & """ muss im 'Administrator'-Kontext erstellt werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich das """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte das Kopieren nach " & Txt & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "0441 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
If not fso.FileExists( Txt ) Then
Trace32Log "0447 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = ""
Tst = Tst & "Die Datei """ & Txt & """ muss im 'Administrator'-Kontext erstellt werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich das """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte das Kopieren nach " & Txt & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "0458 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
ProgrExe = Txt
Trace32Log "0463 :: Neue ProgrExe: " & ProgrExe, 1
MsgBox "Erstellt: " & vbCRLF & vbCRLF & ProgrExe, vbInformation, "0464 :: " & Titel
End If
Exit Function
Else
Trace32Log "0468 :: Suchen-Dialog vom Benutzer abgebrochen.", 2
End If
Else
Trace32Log "0471 :: Suchen-Dialog vom Benutzer abgebrochen.", 2
End If
' imagex.exe nicht gefunden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = vbCRLF & vbCRLF & "Programm kann nicht gestartet werden bzw. ist nicht erreichbar: " & vbCRLF & vbCRLF & vbTab & ProgrExe & vbCRLF & vbCRLF
WSHShell.Popup vbTab & "= = = F E H L E R = = =" & Txt , 15, "0477 :: " & Titel, 4096 + vbCritical
ProgrOK = vbFalse
ProgrExeErreichbar = vbFalse
Trace32Log "0481 :: Beendet 'Function ProgrExeErreichbar'", 3
End Function ' ProgrExeErreichbar( Exe )
'***********************************************************
Sub WIMAuswahl()
'***********************************************************
Trace32Log "0489 :: Anfang 'Sub WIMAuswahl()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tst
Trace32Log "0494 :: Aktuell WIMGewaehlt (Dateiname): '" & WIMGewaehlt & "'", 1
Tst = WIMGewaehlt
If InStr( Tst, "\" ) = 0 And InStr( Tst, ":" ) = 0 Then
Tst = RemoteSystemDrive( "." )
End If
If Len( WIMGewaehlt ) > 7 Then Tst = fso.GetParentFolderName( WIMGewaehlt )
' MsgBox WIMGewaehlt, , "0500 :: "
If not fso.FileExists( Tst ) AND not fso.FolderExists( Tst ) Then
Tst = fso.GetParentFolderName( AktVerz )
If not fso.FolderExists( Tst ) Then Tst = AktVerz
End If
If ProgrVerz = "MININT" Then ' bei WinPE
Trace32Log "0508 :: Input-Dialog für WIM-Auswahl wird angezeigt mit Verz.: " & AktVerz, 1
Tst = BFFAusWahlOCX( AktVerz, Tst, "wim" )
' Tst = InputBox( "Bitte den kompletten Pfad zu einem WIM eingeben:", Titel, AktVerz )
Trace32Log "0511 :: Input-Dialog für WIM-Auswahl Ergebnis: '" & Tst & "'", 1
Else
Trace32Log "0513 :: Datei-Suchen-Dialog für WIM-Auswahl öffnet mit Verz.: " & Tst, 1
Tst = BFFVerzDateitype( Tst, "wim" )
' Tst = ChooseFile( )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0517 :: Datei-Suchen-Dialog für WIM-Auswahl Ergebnis: '" & Tst & "'", 1
End If
Trace32Log "0520 :: Datei-Suchen-Dialog für WIM-Auswahl Ergebnis: '" & Tst & "'", 1
If InStr( Tst, "\\" ) = 1 OR InStr( Tst, ":\" ) = 2 Then
WIMGewaehlt = Tst
Trace32Log "0524 :: Neu WIMGewaehlt: '" & WIMGewaehlt & "'", 1
If not fso.GetExtensionName( UCase( WIMGewaehlt ) ) = "WIM" Then
WIMGewaehlt = WIMGewaehlt & ".WIM"
Trace32Log "0527 :: Neu WIMGewaehlt mit Dateiendung: '" & WIMGewaehlt & "'", 1
End If
Else
Trace32Log "0530 :: Datei-Suchen-Dialog für WIM-Auswahl ohne 'vernüftiges' Ergebnis '" & Tst & "'", 2
End If
Trace32Log "0533 :: Beendet 'Sub WIMAuswahl()'", 1
Call WIMBuRMenu()
End Sub ' WIMAuswahl()
'***********************************************************
Sub WIMBuRMenu()
'***********************************************************
Trace32Log "0543 :: Anfang 'Sub WIMBuRMenu()'", 1
On Error Resume Next
window.moveto 0, 0
window.resizeto 700, 670
On Error Goto 0
Dim Txt, Tst, T
Tst = LCase( ProgrVerz & "\" & DSProgr & "\" )
Tst = LCase( DSProgr & "\" & Titel )
' MsgBox LCase( HtaSelbst ) & vbCRLF & Tst, , "0553 :: " & Titel
If InStr( LCase( HtaSelbst ), Tst ) > 1 OR ProgrVerz = "MININT" Then ' bei WinPE
T = ""
Else
T = "<input class=""InputNr"" onClick=""SubWIMBuRInst()"" type=""submit"" value=""Inst."" title=""" & Titel & " auf diesen PC installieren.""> "
End If
If not InStr( WIMGewaehlt, "\\" ) = 1 AND not InStr( WIMGewaehlt, ":\" ) = 2 Then
T = T & "<input class=""WIMAanzWahl1"" onClick=""WIMAuswahl()"" accesskey=""a"" type=""submit"" value=""" & WIMGewaehlt & " Hier klicken und auswählen . . . "" title=""WIM auswählen."">"
Else
Txt = Mid( WIMGewaehlt, 1, InStr( Mid( WIMGewaehlt, 7 ), "\" ) + 6 )
Txt = Txt & " . . . " & Mid( WIMGewaehlt, InStrRev( WIMGewaehlt, "\" ) )
If Len( WIMGewaehlt ) < 90 Then Txt = WIMGewaehlt
T = T & "<input class=""WIMAanzWahl2"" onClick=""WIMAuswahl()"" accesskey=""a"" type=""submit"" value=""" & Txt & """ title=""" & WIMGewaehlt & """>"
End If
T = T & "</center><span Style="" height: 34px; ""></span>"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRInfo()"" accesskey=""w"" type=""submit"" value="" WIM-BuR "" title=""Informationen über 'WIM - Backup und Restore'."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRBackup()"" accesskey=""b"" type=""submit"" value="" Backup "" title=""Datei(en) in ein WIM sichern."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRRestore()"" accesskey=""r"" type=""submit"" value="" Restore "" title=""Datei(en) aus einem WIM wiederherstellen."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRDelete()"" accesskey=""d"" type=""submit"" value="" Delete "" title=""Daten aus einem WIM löschen."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRWIMInfo()"" accesskey=""i"" type=""submit"" value="" Informations "" title=""Statistik und Informationen über ein WIM."">"
document.all.MenuEing.innerHTML = T
If MenueAkt = "BURINFO" Then WIMBuRInfo()
If MenueAkt = "BACKUP" Then WIMBuRBackup()
If MenueAkt = "RESTORE" Then WIMBuRRestore()
If MenueAkt = "DELETE" Then WIMBuRDelete()
If MenueAkt = "WIMINFO" Then WIMBuRWIMInfo()
Trace32Log "0584 :: Beendet 'Sub WIMBuRMenu()'", 1
End Sub ' WIMBuRMenu()
'***********************************************************
Sub WIMBuRInfo()
'***********************************************************
Trace32Log "0591 :: Anfang 'Sub WIMBuRInfo()'", 1
MenueAkt = "BURINFO"
Const Abstand = "<br><span style="" line-height: 1.0em; font-size:0.5em; ""><br></span>"
Dim T
T = T & "<span>"
' T = T & "<span style="" line-height: 1.1em; "">"
T = T & "<b>" & Titel & "</b> ist ein HTA und ermöglicht "
T = T & "eine Datensicherung bzw. Datenrücksicherung in/aus WIM-Dateien "
T = T & "mit dem Microsoft-Tool <b>ImageX.exe</b> . . . oder man nehme "
T = T & "<a href=""http://www.autoitscript.com/gimagex"">GImageX</a>."
T = T & Abstand
T = T & "Seit Windows Vista befinden sich auf der Installations-DVD die Dateien zur "
T = T & "Windows-Installation in einem WIM (Windows Imaging File Format) und werden "
T = T & "von ImageX.exe (von der DVD) extrahiert. "
T = T & "ImageX.exe gilt als zuverlässig um Daten in WIMs zu speichern."
T = T & Abstand
T = T & "<u>Vorteile</u> durch die Verwendung von ImageX.exe:"
T = T & "<br> • Das verwendete ""Single-Instancing""-Verfahren speichert Dateidaten getrennt von den<br>"
T = T & " Pfadinformationen, d.h. Dateien, die in mehreren Pfaden oder mehreren Images im WIM<br>"
T = T & " vorhanden sind, werden nur einmal gespeichert, sind aber für alle Images verfügbar."
T = T & "<br> • Wählbare Komprimierung (none, maximum, fast)."
T = T & "<br> • WIMs lassen sich in die Verzeichnisstruktur einbinden (mounten; vergl. "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc766067(loband).aspx"">WIM bereit stellen</a>)."
T = T & Abstand
T = T & "<u>Nachteile</u> bzw. Einschränkungen bei der Verwendung von ImageX.exe:"
T = T & "<br> • <span style=""color:#f60; font-weight: bold"">Netzlaufwerke lassen sich nicht sichern!</span> Und: Nein, mappen hilft nicht!"
T = T & "<br> • Beim Löschen von im WIM enthaltenen Images werden 'nur' die Pfadinformationen zu den<br>"
T = T & " Dateien gelöscht, nicht aber überflüssige Dateien selbst - das WIM wird also nicht kleiner."
T = T & "<br> • Beim Löschen des letzten Image im WIM bleiben die Image-Informationen erhalten, auf die<br>"
T = T & " Daten ist aber kein Zugriff (Restore) möglich! "
T = T & "<br> • WIMs sind auf NTFS-Dateisysteme zu speichern (u.a. wegen der 2GB-Grenze bei FAT). "
T = T & "<br> • Folgende NTFS-Features werden nicht unterstützt: Erweiterte Attribute; Objektkennungen;<br>"
T = T & " Analysepunkte, die weder symbolische Verknüpfungen noch Abzweigungen sind; <br>"
T = T & " ursprünglich komprimierte Dateien sind nach der Wiederherstellung nicht komprimiert."
T = T & "<br> • Während Lese-/Schreibzugriffen ist kein Lesen/Schreiben möglich. "
T = T & "<br> • Die Daten in einem WIM lassen sich nicht verschlüsseln - kein Passwortschutz. "
T = T & "<br> • Bei Dateizugriff-Fehlern bricht ImageX.exe <u>immer</u> mit einem Fehler ab. "
T = T & Abstand
T = T & "<u>Informationen</u>: "
T = T & "<br> • "
T = T & "MS wünscht keinen ImageX.exe-Download - man muss das WAIK installieren."
T = T & "<br> • "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc722145(loband).aspx"">""Was ist ImageX.exe?""</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc722145(loband).aspx"">(en)</a>; "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc749447%28WS.10%29.aspx"">""ImageX - Befehlszeilenoptionen""</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc749447%28WS.10%29.aspx"">(en)</a>"
T = T & "<br> • "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/dd349350(WS.10).aspx"">WAIK (Win Automated Installation Kit)</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/dd349343(WS.10).aspx"">(en)</a>; "
T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?displaylang=de&FamilyID=696dd665-9f76-4177-a811-39c26d3b3b34"">WAIK-Download</a> "
T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?displayLang=en&FamilyID=696dd665-9f76-4177-a811-39c26d3b3b34"">(en)</a>"
T = T & "<br> • "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc749528(WS.10).aspx"">Benutzerhandbuch zum Windows Automated Installation Kit (Windows AIK)</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc749528(WS.10).aspx"">(en)</a>"
' T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?familyid=fbbe4826-883b-4893-92d1-4ed1cc4d6a7f&displaylang=de"">WAIK - Benutzerhandbuch für Windows Vista</a> "
' T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?FamilyID=993c567d-f12c-4676-917f-05d9de73ada4&DisplayLang=en"">(en)</a>"
T = T & "<br> • "
T = T & "<a href=""http://msdn.microsoft.com/en-us/library/ms536471.aspx"">HTA (HTML Applications; en)</a> "
T = T & "<a href=""http://dieseyer.de/dse-wsh-mehr-hta.html"">HTA auf dieseyer.de</a>"
' T = T & Abstand
' T = T & "Ursprünglich sollte diese Anwendung und das Menü durchgehend deutschsprachig "
' T = T & "sein. Leider gibt es im Deutschen für 'Backup' und 'Restore' "
' T = T & "keine ähnlich kurzen und geläufigen Begriffe. Aus diesem Grund "
' T = T & "ist 'nur' das Menü englisch - der REST deutsch. "
T = T & Abstand
T = T & "Änderungswünsche und Ergänzungen bitte an 'dieseyer@gmx.de' . . . "
T = T & "Fehler natürlich auch.<br>"
T = T & Abstand
T = T & "<center style="" font-size:7Pt; "">"
T = T & "<a href=""http://dieseyer.de/scr/WIM-BuR.hta"" ><b>" & Titel & ".hta v1.00</b></a>"
T = T & "<a href=""http://dieseyer.de/dse-impressum.html"" > • © 2010 by dieseyer • all rights reserved • </a>"
T = T & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
' T = T & "<a href=""http://dieseyer.de"" ><b>" & Titel & ".hta</b> • © 2010 by dieseyer • all rights reserved • <b>www.dieseyer.de</b></a>"
T = T & "</center>"
T = T & Abstand
T = T & "<center style="" font-size:7Pt; ""><span id=""HtaInfo"" ></span></center>"
T = T & "</span>"
document.all.MenuRahmen.innerHTML = BuRInfoMenue & T
Trace32Log "0684 :: Beendet 'Sub WIMBuRInfo()'", 1
End Sub ' WIMBuRInfo()
'***********************************************************
Sub SubWIMBuRInst()
'***********************************************************
Trace32Log "0692 :: Anfang 'Sub SubWIMBuRInst()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, T, errTst
Dim ZielDatei : ZielDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & "_Install.hta"
On Error Resume Next
If not fso.FolderExists( ProgrVerz & "\" & DSProgr & "\" ) Then fso.CreateFolder ProgrVerz & "\" & DSProgr & "\"
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then
Trace32Log "0702 :: Verzeichnis kann nicht erstellt werden: " & ProgrVerz & "\" & DSProgr & "\", 3
Trace32Log "0703 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Txt = ""
Txt = Txt & "Verzeichnis kann nicht erstellt werden: " & ProgrVerz & "\" & DSProgr & "\"
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Diese Aktion muss ggf. im 'Administrator'-Kontext ausgeführt werden - dafür "
Txt = Txt & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Txt = Txt & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Txt = Txt & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Txt = Txt & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Txt = Txt & "so sollte 'es' dann gelingen . . ."
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Soll '" & HTASelbst & "' beendet werden?"
Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "0716 :: " & Titel )
If Txt = vbYes Then Trace32Log "0717 :: Wird (normal) beendet: " & HtaSelbst, 1
If Txt = vbYes Then self.close
Exit Sub
End If
' MsgBox HTASelbst & vbCRLF & ProgrVerz & "\" & DSProgr & "\", , "0721 :: "
On Error Resume Next
fso.CopyFile HTASelbst, ProgrVerz & "\" & DSProgr & "\"
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then
Trace32Log "0728 :: In Verzeichnis kann nicht geschrieben werden: " & ProgrVerz & "\" & DSProgr & "\", 3
Trace32Log "0729 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Txt = ""
Txt = Txt & vbTab & "In das Verzeichnis kann nicht gesschrieben werden: "
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & ProgrVerz & "\" & DSProgr & "\"
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Diese Aktion muss ggf. im 'Administrator'-Kontext ausgeführt werden - dafür "
Txt = Txt & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Txt = Txt & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Txt = Txt & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Txt = Txt & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Txt = Txt & "so sollte 'es' dann gelingen . . ."
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Soll '" & HTASelbst & "' beendet werden?"
Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "0744 :: " & Titel )
If Txt = vbYes Then Trace32Log "0745 :: Wird (normal) beendet: " & HtaSelbst, 1
If Txt = vbYes Then self.close
Exit Sub
End If
Trace32Log "0750 :: Soll erstellt werden: '" & ZielDatei & "'", 1
' MsgBox ZielDatei, , "0751 :: "
T = T & vbCRLF & "</html><head>"
T = T & vbCRLF & "<HTA:APPLICATION ID=""oHTA"" APPLICATIONNAME=""Installieren"" SINGLEINSTANCE=""yes"" MAXIMIZEBUTTON=""no"" SHOWINTASKBAR=""yes"" SCROLL=""No"" NAVIGABLE=""no"" >"
T = T & vbCRLF & "<title>Installieren . . . </title>"
T = T & vbCRLF & "<style type=""text/css"">"
T = T & vbCRLF & "html, body { font-size: 9pt; background-color: #116; color: #ec0; font-weight: normal; font-family: verdana, arial, sans-serif; }"
T = T & vbCRLF & ".InputBttn { margin-left: 09px; font-weight: bold; background-color: #116; color: #ec0; width: 120px; height: 30px; }"
T = T & vbCRLF & "</style>"
T = T & vbCRLF & "</head>"
T = T & vbCRLF & "<script language=""VBscript"">"
T = T & vbCRLF & " Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl"
T = T & vbCRLF & " Dim fso : Set fso = CreateObject(""Scripting.FileSystemObject"")"
T = T & vbCRLF & " Const Titel = """ & Titel & " installieren"""
T = T & vbCRLF & " Const ProgrName = """ & Titel & """"
T = T & vbCRLF & " Const ProgrBeschr = """ & document.title & """"
T = T & vbCRLF & " Const ProgrQuelle = """ & AktVerz & "\"""
T = T & vbCRLF & " Const TestDatei = ""Test.txt"""
T = T & vbCRLF & " Const DSProgr = """ & DSProgr & """"
T = T & vbCRLF & " Trace32Log ""Es geht los . . ."", 1"
T = T & vbCRLF & " Dim ProgrVerz : ProgrVerz = """ & ProgrVerz & "\" & DSProgr & """"
'T = T & vbCRLF & " Dim ProgrVerz"
'T = T & vbCRLF & " ProgrVerz = CreateObject(""WScript.Shell"").ExpandEnvironmentStrings(""%ProgramFiles(x86)%"")"
'T = T & vbCRLF & " If InStr( ProgrVerz, ""%"" ) > 0 Then"
'T = T & vbCRLF & " ProgrVerz = CreateObject(""WScript.Shell"").ExpandEnvironmentStrings(""%ProgramFiles%"")"
'T = T & vbCRLF & " End If"
'T = T & vbCRLF & " ProgrVerz = ProgrVerz & ""\" & DSProgr & """"
' T = T & vbCRLF & " ' Verzeichnis und TestDatei erstellen"
' T = T & vbCRLF & " ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
' T = T & vbCRLF & " ' für späteren Test auf Existenz"
' T = T & vbCRLF & " ' On Error Resume Next"
' T = T & vbCRLF & " If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz"
' T = T & vbCRLF & " fso.OpenTextFile( ProgrVerz & ""\"" & TestDatei, 2, true).WriteLine ( ""dieseyer.de - "" & Now() & vbCRLF & ProgrVerz & ""\"" & TestDatei )"
' T = T & vbCRLF & " fso.CopyFile oHTA.CommandLine, ProgrVerz & ""\"", True"
T = T & vbCRLF & " "
' T = T & vbCRLF & " Sub Trace32Log( LogTxt, ErrType ) : End Sub"
T = T & vbCRLF & ProzedurInTxt( "InstBeimLaden(" )
T = T & vbCRLF & ProzedurInTxt( "SchreibTest(" )
T = T & vbCRLF & ProzedurInTxt( "InsInstStart(" )
T = T & vbCRLF & ProzedurInTxt( "LinkErstellen(" )
T = T & vbCRLF & ProzedurInTxt( "InstFehlerMsgBox(" )
T = T & vbCRLF & ProzedurInTxt( "DateiTypRegistrieren(" )
T = T & vbCRLF & ProzedurInTxt( "ist64bit(" )
T = T & vbCRLF & ProzedurInTxt( "Trace32Log(" )
T = T & vbCRLF & "<" & "/" & "script>"
T = T & vbCRLF & "<body onLoad=""InstBeimLaden()"">"
T = T & vbCRLF & "<span id=""AllesHtml""></span><br>"
' T = T & vbCRLF & "<center style="" font-size:6Pt; "">" & ZielDatei & "</center>"
T = T & vbCRLF & "</body></html>"
' Trace32Log "0803 :: " & T, 1
' HTA schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0807 :: Datei soll geschrieben werden: " & ZielDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( ZielDatei, 2, true, -1 ).Write( T )
Trace32Log "0809 :: Datei ist geschrieben: " & ZielDatei, 1
' HTA starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielDatei = "mshta.exe """ & ZielDatei & """"
Trace32Log "0814 :: Folgt (verzögert): " & Zieldatei, 1
window.setTimeout "ProgrRun('" & ZielDatei & "')", 1*333
Trace32Log "0817 :: 'Self.Close' folgt (verzögert) . . . ", 1
window.setTimeout "Self.Close", 2*333
Trace32Log "0820 :: Beendet 'Sub SubWIMBuRInst()'", 1
End Sub ' SubWIMBuRInst()
'***********************************************************
Sub SchreibTest()
'***********************************************************
Dim errTst
On Error Resume Next
If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then Call InstFehlerMsgBox( "0833 :: Verzeichnis kann nicht erstellt werden: " & ProgrVerz & vbCRLF & vbCRLF & errTst & vbCRLF & vbCRLF & "HTA wird beendet!" ) : Self.Close : Exit Sub
On Error Resume Next
fso.CopyFile Replace( oHTA.CommandLine, """", "" ), ProgrVerz & "\"
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then Call InstFehlerMsgBox( "0839 :: In Verzeichnis kann nicht geschrieben werden: " & vbCRLF & vbCRLF & ProgrVerz & vbCRLF & vbCRLF & errTst & vbCRLF & vbCRLF & "HTA wird beendet." ) : Self.Close : Exit Sub
' If not fso.FolderExists( ProgrVerz ) Then Call InstFehlerMsgBox( "0841 :: Verzeichnis konnte nicht erstellt werden: " & ProgrVerz ) : Self.Close : Exit Sub
' If not fso.FileExists( ProgrVerz & "\" & TestDatei ) Then Call InstFehlerMsgBox( "0842 :: Datei konnte nicht erstellt werden: " & ProgrVerz & "\" & TestDatei ) : Self.Close : Exit Sub
' MsgBox fso.OpenTextFile( ProgrVerz & "\" & TestDatei, 1 ).ReadAll, , "830:: "
End Sub ' SchreibTest()
'***********************************************************
Sub ProgrRun( Progr )
'***********************************************************
' MsgBox "Progr: " & Progr, , "0850 :: "
Trace32Log "0851 :: Progr: " & Progr, 1
Trace32Log "0852 :: 'Progr' wird gestartet (ohne Warten auf Ende) . . . ", 1
CreateObject("WScript.Shell").Run Progr, , False
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0857 :: Ist gestartet '" & Progr & "'", 1
End Sub ' ProgrRun( Progr )
'***********************************************************
Function InstBeimLaden() ' ruft einige Routinen auf
'***********************************************************
Dim Txt
Dim User : User = CreateObject("WScript.Network").UserName
window.moveto 30, 30
window.resizeto 370, 360
Txt = Txt & "<center>"
Txt = Txt & "Installation des Programms"
Txt = Txt & "<h2>''" & ProgrName & "''</h2>"
Txt = Txt & "</center>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""1"" value=""1""> Desktop-Symbol nur für """ & User & """ erzeugen.<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""2"" value=""2""> Desktop-Symbol für alle Anwender erzeugen.<br>"
Txt = Txt & "<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""3"" value=""3""> In 'Programme' nur für """ & User & """ eintragen.<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""4"" value=""4""> In 'Programme' für alle Anwender eintragen.<br>"
Txt = Txt & "<br>"
' Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""5"" value=""5""> Schnellstart-Symbol für """ & User & """ anlegen.<br>"
' Txt = Txt & "<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""6"" value=""6""> ''" & ProgrName & "'' für WIM-Dateien registrieren.<br>"
Txt = Txt & "<br>"
Txt = Txt & "<center>"
Txt = Txt & "<input class=""InputBttn"" type=""SubMit"" onClick=""InsInstStart()"" accesskey=""s"" value=""Installieren"">"
Txt = Txt & " "
Txt = Txt & "<input class=""InputBttn"" type=""SubMit"" onClick=""Self.Close()"" accesskey=""a"" value=""Abbrechen"">"
' Txt = Txt & "<input class=""InputBttn"" type=""SubMit"" onClick=""InstEnde()"" value=""Abbrechen""><br>"
Txt = Txt & " "
Txt = Txt & "</center>"
document.all.AllesHtml.innerHTML = Txt
window.setTimeout "SchreibTest", 1*333
End Function ' InstBeimLaden()
'***********************************************************
Sub InsInstStart()
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AusgewLink : Set AusgewLink = document.getElementsByName("InstAuswahl")
Dim ProgrPfad : ProgrPfad = ProgrVerz & "\" & ProgrName & ".hta"
' : ProgrPfad = ProgrName & ".hta"
' MsgBox "ProgrVerz: " & ProgrVerz & vbCRLF & "ProgrPfad: " & ProgrPfad, , "0908 :: " ' Program Files C:\Programme\dieseyer.de\
Trace32Log "0909 :: ProgrPfad : '" & ProgrPfad & "'", 1
Trace32Log "0910 :: ProgrVerz : '" & ProgrVerz & "'", 1
Dim Ausw, Txt, Tst, m
' ausgewählte (angehakte) CheckBoxen prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For m = 0 to AusgewLink.length - 1
If AusgewLink( m ).checked Then Ausw = Ausw & "*" & m & "*"
Next
' MsgBox Ausw, , "0919 :: " & Titel
If InStr( Ausw, "*" ) = 0 Then
Txt = "Ohne Link bzw. ohne Symbol macht eine" & vbCRLF & "Installation keinen Sinn - stimmts?!"
MsgBox Txt, vbInformation, "0923 :: " & Titel
Exit Sub
End If
' zusätzliche Dateien kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz ' : MsgBox "fso.CreateFolder " & ProgrVerz, , "0930 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0932 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & "comdlg32.ocx"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0935 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0937 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & "ImageX.exe"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0940 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0942 :: " & Tst ) : Self.Close : Exit Sub
On Error GoTo 0
' .hta und .ico nach C:\Programme\dieseyer.de kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = ""
On Error Resume Next
If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz ' : MsgBox "fso.CreateFolder " & ProgrVerz, , "0952 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0954 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".hta"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0957 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0959 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".exe"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0962 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0964 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".com"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0967 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0969 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".ico"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0972 :: "
' Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0974 :: " & Tst ) : Self.Close : Exit Sub
On Error GoTo 0
' Verknüpfungen erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If InStr( Ausw, "*0*" ) > 0 AND InStr( Ausw, "*1*" ) = 0 Then
Tst = 00 ' C:\Dokumente und Einstellungen\DSeyer\Desktop
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "0983 :: " & Titel
Trace32Log "0984 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*1*" ) > 0 Then
Tst = 25 ' C:\Dokumente und Einstellungen\All Users\Desktop
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "0991 :: " & Titel
Trace32Log "0992 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*2*" ) > 0 AND InStr( Ausw, "*3*" ) = 0 Then
Tst = 02 ' C:\Dokumente und Einstellungen\DSeyer\Startmenü\Programme
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "0999 :: " & Titel
Trace32Log "1000 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*3*" ) > 0 Then
Tst = 23 ' C:\Dokumente und Einstellungen\All Users\Startmenü\Programme
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "1007 :: " & Titel
Trace32Log "1008 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*4*" ) > 0 Then
Tst = 26 ' Schnellstart C:\Dokumente und Einstellungen\DSeyer\Anwendungsdaten
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
Tst = Tst & "\Microsoft\Internet Explorer\Quick Launch"
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "1016 :: " & Titel
Trace32Log "1017 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*5*" ) > 0 Then
' MsgBox fso.GetFileName( ProgrPfad ) & vbCRLF & ProgrPfad, , "1022 :: "
Call DateiTypRegistrieren( "wim", ProgrPfad )
End If
MsgBox """" & ProgrName & """ wurde nach" & vbCRLF & vbCRLF & ProgrPfad & vbCRLF & vbCRLF & "kopiert und wird jetzt gestartet.", vbInformation, "1026 :: " & Titel
Tst = "mshta.exe """ & ProgrPfad & """"
Trace32Log "1029 :: Soll gestartet : " & Tst, 1
Trace32Log "1030 :: Wird gestartet (ohne Warten auf Ende) . . . ", 1
CreateObject("WScript.Shell").Run Tst, , False
Trace32Log "1034 :: Ist gestartet : " & Tst, 1
Trace32Log "1036 :: 'Self.Close' folgt . . . ", 1
window.setTimeout "Self.Close", 333
Trace32Log "1038 :: 'Self.Close' wurde (mit Zeitverzögerung) abgesetzt.", 1
End Sub ' InsInstStart()
'***********************************************************
Sub LinkErstellenAlt( LinkVerz, ProgrBeschr, ProgrPfad )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim ProgrName : ProgrName = fso.GetBaseName( ProgrPfad )
Dim LinkPfad : LinkPfad = LinkVerz & "\" & ProgrName & ".lnk"
Dim IconPfad : IconPfad = Mid( ProgrPfad, 1, InStrRev( ProgrPfad, "." ) ) & "ico"
Dim oShellLink
Dim Tst
Tst = Tst & "LinkVerz: " & vbTab & LinkVerz & vbCRLF
Tst = Tst & "ProgrBeschr: " & vbTab & ProgrBeschr & vbCRLF
Tst = Tst & "ProgrPfad: " & vbTab & ProgrPfad & vbCRLF
Tst = Tst & "ProgrName: " & vbTab & ProgrName & vbCRLF
Tst = Tst & "LinkPfad: " & vbTab & LinkPfad & vbCRLF
Tst = Tst & "IconPfad: " & vbTab & IconPfad & vbCRLF
' MsgBox Tst, , "1061 :: "
' Set oShellLink = CreateObject("WScript.Shell").CreateShortcut(strDesktop & "\Shortcut Script.lnk")
Set oShellLink = CreateObject("WScript.Shell").CreateShortcut( LinkPfad )
' oShellLink.TargetPath = WScript.ScriptFullName
oShellLink.TargetPath = ProgrPfad
oShellLink.WindowStyle = 1
' oShellLink.Hotkey = "CTRL+SHIFT+F"
' oShellLink.IconLocation = "notepad.exe, 0"
oShellLink.IconLocation = IconPfad
' oShellLink.Description = "Shortcut Script"
oShellLink.Description = ProgrBeschr
' oShellLink.WorkingDirectory = strDesktop
' oShellLink.WorkingDirectory = LinkVerz
oShellLink.WorkingDirectory = "%TEMP%"
oShellLink.Save
End Sub ' LinkErstellenAlt( LinkVerz, ProgrBeschr, ProgrPfad )
'***********************************************************
Sub InstFehlerMsgBox( Txt )
'***********************************************************
MsgBox vbTab & "Fehler:" & vbCRLF & vbCRLF & Txt, vbCritical , "1091 :: " & Titel
End Sub ' InstFehlerMsgBox( Txt )
'*** v8.4 *** www.dieseyer.de ******************************
Function ProzedurInTxt( ProzName )
'***********************************************************
' Übergibt (aus dem aktuellen VBS) den Inhalt einer Prozedur
ProzName = LCase( ProzName )
Dim i
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, ZeileAkt, ProzOK
ProzOK = "-OK"
Txt = "'***********************************************************"
Dim FileIn : Set FileIn = fso.OpenTextFile( HtaSelbst, 1 )
Do While Not ( FileIn.atEndOfStream )
ZeileAkt = FileIn.Readline
Tst = LCase( ZeileAkt )
If ProzOK = "-OK" Then
Tyt = InStr( Tst, "function " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
Tyt = InStr( Tst, "sub " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
End If
If ProzOK = "OK" Then Txt = Txt & vbCRLF & ZeileAkt ' : MsgBox now() & vbCRLF & Txt, , "1119 :: " : i = i + 1 : If i > 10 Then WScript.Quit
If ProzOK = "OK" AND InStr( Tst, "end function" ) > 0 Then Exit Do
If ProzOK = "OK" AND InStr( Tst, "end sub" ) > 0 Then Exit Do
Loop
FileIn.Close : Set FileIn = nothing
Txt = Txt & vbCRLF & "'***********************************************************"
ProzedurInTxt = Txt ' : MsgBox now() & vbCRLF & ProzedurInTxt, , "1130 :: "
End Function ' ProzedurInTxt( ProzName )
'***********************************************************
Sub WIMBuRBackup()
'***********************************************************
Trace32Log "1138 :: Anfang 'Sub WIMBuRBackup()'", 1
MenueAkt = "BACKUP"
Dim T
T = T & "<br> <b>ACHTUNG</b>: Folgenden NTFS-Features werden von ImageX.exe nicht unterstützt:"
T = T & "<br> • Erweiterte Attribute."
T = T & "<br> • Objektkennungen."
T = T & "<br> • Analysepunkte, die weder symbolische Verknüpfungen noch Abzweigungen sind."
T = T & "<br> • Komprimierte Dateien werden beim Restore unkomprimiert gespeichert."
T = T & "<br> Näheres bei MS: "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc722145(loband).aspx"">'de-de'</a> oder "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc722145(loband).aspx"">'en-us'</a><br>"
T = T & "<br>"
T = T & "<input class=""InputSonst"" onClick=""BackupQuelle()"" type=""submit"" accesskey=""q"" value=""Quelle""> "
If DatenQuelle = "" Then
T = T & "(Es ist kein Quell-Verzeichnis für eine Datensicherung fest gelegt.)"
Else
T = T & " """ & DatenQuelle & """ <br><br>"
T = T & "<input class=""InputSonst"" onClick=""SubBackup()"" type=""submit"" accesskey=""s"" value="" Start ""> "
' T = T & " Mit einem Klick auf [Start] werden die Dateien der 'Quelle' in das WIM kopiert. "
T = T & " Datei(en) und Verzeichnis(se) der 'Quelle' werden in das WIM kopiert. "
T = T & "<br>"
If not ProgrVerz = "MININT" Then ' bei WinPE
T = T & "<br>"
T = T & "<input class=""InputSonst"" onClick=""SubBackupTask()"" type=""submit"" accesskey=""t"" value="" Task ""> "
T = T & " Es wird ein 'Geplanter Taks' für ein tägliches Backup konfiguriert."
T = T & "<br>"
End If
T = T & "<br>"
T = T & " ImageX.exe " & ProgrVersion & " erhält folgende Startparameter bei der WIM-Erstellung:"
T = T & "<br>"
T = T & "<br>"
T = T & " <b>" & ProgrPara & "</b>"
End If
document.all.MenuRahmen.innerHTML = BuRBackupMenue & T
Trace32Log "1175 :: Beendet 'Sub WIMBuRBackup()'", 1
End Sub ' WIMBuRBackup()
'***********************************************************
Sub SubBackup()
'***********************************************************
Trace32Log "1182 :: Anfang 'Sub SubBackup()'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, errTst, i, CmdBef, ExeDauer, ZeitPunkt
Dim CMDDatei : CMDDatei = CMDPfad & "_Backup.cmd"
Trace32Log "1187 :: Gebildete CMDDatei-Name: " & CMDDatei, 1
ZeitPunkt = AktuelleDMTFDateTime
ZeitPunkt = Mid( ZeitPunkt, 1, InStr( ZeitPunkt, "." ) - 1 )
Tst = WIMGewaehlt
If not InStr( Tst, "\\" ) = 1 AND not InStr( Tst, ":\" ) = 2 Then
MsgBox WIMGewaehlt & vbCRLF & vbCRLF & ". . . es kann also kein Sicherung gestartet werden.", vbCritical, "1194 :: " & Titel
Call WIMAuswahl()
Exit Sub
End if
' MsgBox "WIMGewaehlt: '" & WIMGewaehlt & "'", , "1198 :: "
If fso.FileExists( WIMGewaehlt ) Then
If fso.GetFile( WIMGewaehlt ).Size < 50 Then
MsgBox WIMGewaehlt & vbCRLF & "ist nur " & fso.GetFile( WIMGewaehlt ).Size & "Byte groß und wird gelöscht.", vbInformation,"1201 :: " & Titel
fso.DeleteFile WIMGewaehlt, True
Trace32Log "1203 :: 'WIMGewaehlt' gelöscht, weil zu klein: " & WIMGewaehlt, 1
' Ein WIM ohne Inhalt ist min 1,5 KByte groß
Else
' MsgBox WIMGewaehlt & ": " & fso.GetFile( WIMGewaehlt ).Size & "Bytes", , "1206 :: "
Trace32Log "1207 :: 'WIMGewaehlt' nicht gelöscht, weil " & fso.GetFile( WIMGewaehlt ).Size & "Bytes groß.", 1
End If
Else
Trace32Log "1210 :: 'WIMGewaehlt' wird neu angelegt . . . ", 1
End If
' MsgBox CmdBef, , "1213 :: "
' imagex /capture d: d:\imaging\data.wim "Drive D"
' imagex /append d: d:\imaging\data.wim "Drive D"
' /CHECK
' Enables WIM integrity checking. Flag must be supplied during updates.
' /COMPRESS [maximum | fast | none]
' Specifies the type of compression used for the initial capture operation.
' /CONFIG configuration_file.ini
' Enables use of a configuration file for exclusion and compression options.
' configuration_file.ini - The path to the configuration file.
' /NORPFIX
' Disables reparse point tag fixup. If not provided, reparse points that
' resolve to paths outside of image_path will not be captured
' /SCROLL
' Scrolls output for redirection.
' /VERIFY
' Enables file
Tst = ""
If ProgrVerz = "MININT" AND fso.FolderExists( "X:\" ) Then
' bei WinPE als winpe.wim im RAM; %systemdrive%=X:
' es gibt keine Geschwindigkeitsvorteile!
Tyt = "X:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
' If Len( errTst ) < 5 Then Tst = " /TEMP X:" : fso.DeleteFile Tyt, True
End If
If ProgrVerz = "MININT" AND fso.FolderExists( "R:\" ) Then
' bei WinPE und %systemdrive%=X: und mit 'seperater' RAM-Disk R:
Tyt = "R:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP R:" : fso.DeleteFile Tyt, True
End If
Txt = "@echo off"
Txt = Txt & vbCRLF & "@echo " & "1254 :: Start: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1255 :: Start: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "" & " Set CmdBef=/CAPTURE"
Txt = Txt & vbCRLF & "if exist """ & WIMGewaehlt & """ Set CmdBef=/APPEND"
' Txt = Txt & vbCRLF & "@Set CmdBef=""" & ProgrExe & """ " & ProgrPara & " %CmdBef% """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " " & ZeitPunkt & """ ""Quelle: " & DatenQuelle & """"
Txt = Txt & vbCRLF & "@Set CmdBef=""" & ProgrExe & """ " & ProgrPara & Tst & " %CmdBef% """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " %DATE% %TIME%"" ""Quelle: " & DatenQuelle & """"
Txt = Txt & vbCRLF & "@echo " & "1260 :: %CmdBef%"
Txt = Txt & vbCRLF & "@echo " & "1261 :: %CmdBef%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "%CmdBef%"
Txt = Txt & vbCRLF & "@Set RC=%errorlevel%"
Txt = Txt & vbCRLF & "@echo " & "1264 :: Ende: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1265 :: Ende: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo Ende: %0 - RC: %RC%"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" Color E4"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!!"
Txt = Txt & vbCRLF & "@echo."
If not ZeitTest = "Ja" Then
Txt = Txt & vbCRLF & "@pause && @pause"
End If
Txt = Txt & vbCRLF & "exit %RC%"
Trace32Log "1277 :: Folgendes wird in die CMD-Datei geschrieben: " & vbCRLF & Txt, 1
' MsgBox "CMDDatei: '" & CMDDatei & "'", , "1278 :: "
' CMD-Zeilen in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1281 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine Txt
Trace32Log "1283 :: Datei ist geschrieben: " & CMDDatei, 1
' CMD-Datei starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1287 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
ExeDauer = Timer()
i = WSHShell.Run( """" & CMDDatei & """", , True )
' MsgBox "RC: '" & i & "'", , "1290 :: "
If ZeitTest = "Ja" Then ExeDauer = vbCRLF & vbCRLF & "ExeDauer: " & ( Timer() - ExeDauer ) & "s"
If not ZeitTest = "Ja" Then ExeDauer = ""
Trace32Log "1293 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
Txt = vbTab & "Datei(en) und Verzeichnis(se) von " & vbCRLF & vbCRLF & DatenQuelle & vbCRLF & vbCRLF & vbTab & "wurden in folgendes WIM kopiert (eingefügt):" & vbCRLF & vbCRLF & WIMGewaehlt & ExeDauer
Tst = vbCritical
Select Case i
Case 0 Tst = vbInformation : Txt = Txt & ExeDauer
Case 1 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültige Befehlszeilenoption!"
Case 2 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": WIMGAPI-Fehler!"
Case 3 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültiges Konfigurationsskript!"
Case 4 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Zugriff verweigert, Administratorrechte erforderlich!"
End Select
If Tst = vbCritical Then
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Wenn keine Zugriffsprobleme beim Schreiben in das WIM "
Txt = Txt & "und keine Zugriffsprobleme beim Lesen der zu sichernden Daten bestehen, "
Txt = Txt & "muss diese Aktion ggf. im 'Administrator'-Kontext ausgeführt werden - dafür wurde "
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%ProgramFiles%")
' MsgBox UCase( HTASelbst ) & vbCRLF & UCase( Tst & "\" & DSProgr & "\" ), , "1310 :: "
If InStr( UCase( HTASelbst ), UCase( Tst & "\" & DSProgr & "\" ) ) = 0 Then
Trace32Log "1313 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Tst = LinkErstellen( AktVerz, document.title, HTASelbst )
Txt = Txt & "im selben Verzeichnis, in der sich das """ & HTASelbst & """ befindet, "
Else
Tst = CreateObject("Shell.Application").Namespace( 0 ).Self.Path
Trace32Log "1318 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Tst = LinkErstellen( Tst, document.title, HTASelbst )
Txt = Txt & "auf dem Desktop "
End If
Txt = Txt & "eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Txt = Txt & "Klickt man mit der rechten Maus-Taste auf diesen Link, kann "
Txt = Txt & "'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Txt = Txt & "so sollte 'es' dann gelingen . . ."
Txt = Txt & vbCRLF & vbCRLF
If InStr( Tst, "Fehler:" ) = 1 Then Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Txt & "Soll '" & HTASelbst & "' beendet werden?"
Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "1329 :: " & Titel )
' Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "1330 :: " & Titel & " " & Len( Txt ) )
If Txt = vbYes Then self.close
If Txt = vbYes Then Trace32Log "1332 :: Wird (normal) beendet: " & HtaSelbst, 1
If Txt = vbYes Then Exit Sub
Else
MsgBox Txt, Tst + 4096, "1335 :: " & Titel
End If
Trace32Log "1338 :: Beendet 'Sub SubBackup()'", 1
Call WIMBuRWIMInfo()
End Sub ' SubBackup()
'***********************************************************
Sub SubBackupTask()
'***********************************************************
Trace32Log "1348 :: Anfang 'Sub SubBackupTask()'", 1
' Frage nach Zeitpunkt für autom. Backup (SCHTASKS)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1352 :: Frage nach Zeitpunkt für autom. Backup (SCHTASKS) . . .", 1
' MsgBox "SubBackupTask", , "1353 :: " & Titel
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim CmdBef, ZeitPunkt, Txt, T, Tst, CMDGepltask
T = ""
T = T & "Zu welcher Uhrzeit sollen täglich Datei(en) und Verzeichnis(se) von" & vbCRLF & vbCRLF
T = T & " " & DatenQuelle & vbCRLF & vbCRLF
T = T & "in dieses WIM (neues Image) kopiert werden?" & vbCRLF & vbCRLF
T = T & " " & WIMGewaehlt & vbCRLF & vbCRLF
T = T & "(Es sind nur volle Stunden wählbar.)" & vbCRLF
Tst = InputBox( T, "1362 :: " & Titel, "18" )
' Bediener-Abbruch
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Tst = vbCancel Then Trace32Log "1366 :: Bediener-Abbruch", 1 : Exit Sub
If VarType( Tst ) = 0 Then Trace32Log "1367 :: Keine Eingabe", 1 : Exit Sub
' Bediener-Fehler (falsche Eingabe)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Prüfung mit 'Exit Sub' am Zeilenende
If InStr( Tst, "." ) > 0 Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1372 :: " & Titel : Trace32Log "1372 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
If InStr( Tst, "," ) > 0 Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1373 :: " & Titel : Trace32Log "1373 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
On Error Resume Next
Tst = Int( Tst )
On Error Goto 0
If not IsNumeric( Tst ) Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1377 :: " & Titel : Trace32Log "1377 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
If Tst < 0 OR Tst > 24 Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1378 :: " & Titel : Trace32Log "1378 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
If Len( Tst ) = 1 Then Tst = "0" & Tst
ZeitPunkt = Tst
Trace32Log "1382 :: Erhaltener Zeitpunkt für autom. Backup (SCHTASKS): " & ZeitPunkt, 1
' Befehlszeile für löschen eines evtl. vorhandenen Tasks
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1386 :: Löschen eines evtl. vorhandenen Tasks (SCHTASKS) . . . ", 1
CmdBef = "SCHTASKS /Delete /TN " & Titel & " /F"
Trace32Log "1388 :: Gebildete CmdBef (SCHTASKS-Befehlszeile): " & CmdBef, 1
Trace32Log "1389 :: CmdBef (SCHTASKS-Befehlszeile) wird gestartet . . . ", 1
WSHShell.Run CmdBef, , True
Trace32Log "1391 :: CmdBef (SCHTASKS-Befehlszeile) ist beendet.", 1
' Befehlszeile für löschen eines evtl. vorhandenen Tasks
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' CmdBef = """" & ProgrExe & """ " & ProgrPara & " /APPEND """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " %date% %time%"" ""Quelle: " & DatenQuelle & """ "
' Trace32Log "1396 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
Txt = "@echo off"
Txt = Txt & vbCRLF & "@Set Log=""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo " & "1401 :: Start: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1402 :: Start: %DATE% %TIME% >> %Log%"
Txt = Txt & vbCRLF & "" & " Set CmdBef=/CAPTURE"
Txt = Txt & vbCRLF & "if exist """ & WIMGewaehlt & """ Set CmdBef=/APPEND"
Txt = Txt & vbCRLF & "@Set CmdBef=""" & ProgrExe & """ " & ProgrPara & " %CmdBef% """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " %DATE% %TIME% "" ""Quelle: " & DatenQuelle & """"
Txt = Txt & vbCRLF & "@echo " & "1406 :: %CmdBef% >> %Log%"
Txt = Txt & vbCRLF & "@echo " & "1407 :: %CmdBef%"
Txt = Txt & vbCRLF & "%CmdBef%"
Txt = Txt & vbCRLF & "@Set RC=%errorlevel%"
Txt = Txt & vbCRLF & "@echo " & "1410 :: Ende: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1411 :: Ende: %DATE% %TIME%>>%Log%.log"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" Color E4"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!!"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! >> %Log%"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo " & "1417 :: %DATE% %TIME% >> %Log%"
Txt = Txt & vbCRLF & "@echo " & "1418 :: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo Ende: %0 - RC: %RC%"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & ":@if not ""%RC%""==""0"" @pause && @pause"
Txt = Txt & vbCRLF & "@pause && @pause"
Trace32Log "1425 :: Folgendes wird in die CMD-Datei geschrieben: " & vbCRLF & Txt, 1
' CMD-Zeilen in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CMDGepltask = CMDPfad & "_GeplTask.cmd"
' MsgBox "CMDGepltask: """ & CMDGepltask & """", , "1430 :: "
Trace32Log "1432 :: Datei soll geschrieben werden: " & CMDGepltask, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDGepltask, 2, True).WriteLine Txt
Trace32Log "1434 :: Datei ist geschrieben: " & CMDGepltask, 1
' Befehlszeile für neuen Tasks
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = "SCHTASKS /Create /TN " & Titel & " /SC Täglich /ST " & ZeitPunkt & ":00:00 /TR """"""""" & CMDGepltask & """"""""""
Trace32Log "1440 :: Gebildete CmdBef (SCHTASKS-Befehlszeile): " & CmdBef, 1
' InputBox CmdBef, "1442 :: ", CmdBef
Trace32Log "1443 :: CmdBef (SCHTASKS-Befehlszeile) wird gestartet . . . ", 1
Tst = WSHShell.Run( CmdBef, , True )
Trace32Log "1445 :: CmdBef (SCHTASKS-Befehlszeile) ist beendet.", 1
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "Diese Funktion ist als Demo implementiert!" & vbCRLF & vbCRLF
Txt = Txt & "Ggf. mus die Ausführung im Administrator-Kontext ausgeführt werden!" & vbCRLF & vbCRLF
Txt = Txt & "Benutzung auf eigene Gefahr! " & vbCRLF & vbCRLF
Txt = Txt & "Das ist _KEIN_ sicheres Verfahren!" & vbCRLF & vbCRLF
Txt = Txt & "! ! ! Unbedingt regelmäßig Prüfen ! ! !" & vbCRLF
Txt = Txt & "~~~~~~~~~~~~~~~~~~~~~~~~"
MsgBox Txt, vbCritical , "1454 :: " & Titel ' & " " & Tst
Trace32Log "1456 :: Beendet 'Sub SubBackupTask()'", 1
End Sub ' SubBackupTask()
'***********************************************************
Sub BackupQuelle()
'***********************************************************
Trace32Log "1464 :: Anfang 'Sub BackupQuelle()'", 1
Trace32Log "1465 :: Aktuelles Verzeichnis DatenQuelle (für Backup): " & DatenQuelle, 1
If ProgrVerz = "MININT" Then ' bei WinPE
Trace32Log "1467 :: InputBox für Verzeichnis-Auswahl (für Backup) wird angezeigt . . . ", 1
DatenQuelle = InputBox( "Bitte den kompletten Pfad zu einem WIM eingeben:", "1468 :: " & Titel, AktVerz )
Trace32Log "1469 :: Neues Verzeichnis DatenQuelle (für Backup): '" & DatenQuelle & "'", 1
Else
Trace32Log "1471 :: Verzeichnis-Auswahl (für Backup) wird gestartet . . . ", 1
DatenQuelle = BFFVerzAuswahl( "1472 :: Zu sicherndes Verzeichnis auswählen:" )
Trace32Log "1473 :: Neues Verzeichnis DatenQuelle (für Backup): '" & DatenQuelle & "'", 1
End If
' MsgBox "Neue DatenQuelle: '" & DatenQuelle & "'" & vbCRLF & "UserProfilVerz: '" & UserProfilVerz & "'", , "1475 :: "
If DatenQuelle = "" Then DatenQuelle = UserProfilVerz()
' MsgBox "Neue DatenQuelle: '" & DatenQuelle & "'", , "1477 :: "
If Len( DatenQuelle ) = 3 AND Mid( DatenQuelle, 3, 1 ) = "\" Then
Trace32Log "1479 :: DatenQuelle '" & DatenQuelle & "' wird gekürzt . . .", 1
DatenQuelle = Left( DatenQuelle, 2 )
Trace32Log "1481 :: DatenQuelle ist gekürzt auf '" & DatenQuelle & "'.", 1
' MsgBox Len( DatenQuelle ) & " - DatenQuelle: '" & DatenQuelle & "'", , "1482 :: " & Titel
End If
Trace32Log "1484 :: Beendet 'Sub BackupQuelle()'", 1
Call WIMBuRBackup()
End Sub ' BackupQuelle()
'***********************************************************
Sub WIMBuRRestore()
'***********************************************************
Trace32Log "1491 :: Anfang 'Sub WIMBuRRestore()'", 1
MenueAkt = "RESTORE"
document.all.MenuRahmen.innerHTML = BuRRestoreMenue & "<br> " & "1493 :: Die WIM-Informationen werden eingelesen. Bitte warten . . ."
window.setTimeout "WIMBuRWIMInfoDaten()", 333
Trace32Log "1495 :: Beendet 'Sub WIMBuRRestore()'", 1
End Sub ' WIMBuRRestore()
'***********************************************************
Sub Partitionieren()
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim DiskPartDatei : DiskPartDatei = UserTempVerz & "\WIM-BuR.diskpart"
Dim FormatCMD : FormatCMD = UserTempVerz & "\WIM-BuRFormat.cmd"
Dim DateiCMD : DateiCMD = UserTempVerz & "\DP_LisDis.cmd"
Dim DiskPartParm, FromatPart, SplitTst, Txt, Tst, Tyt, i, n, PartName, PartSize
' aktuelle HDDs anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DiskPartParm = "lis dis"
fso.OpenTextFile( DiskPartDatei, 2, true).WriteLine( DiskPartParm )
document.all.MenuRahmen.innerHTML = BuRInfoMenue & "Bitte warten . . . "
' MsgBox "DiskPartDatei: '" & DiskPartDatei & "'" & vbCRLF & "DateiCMD: '" & DateiCMD & "' " & vbCRLF & "ExecHiddenPlus", , "1517 :: "
Tst = ExecHiddenPlus( "DISKPART.EXE /s """ & DiskPartDatei & """" )
SplitTst = Split( Tst, vbLF, -1, 1) : n = 0
For i = LBound( SplitTst ) To UBound( SplitTst )
If InStr( UCase( SplitTst( i ) ), "ONLINE" ) > 5 Then
Tyt = SplitTst( i ) : Tyt = Trim( Tyt )
Tyt = Replace( Tyt, vbTab, "" ) : Tyt = Replace( Tyt, " ", " " ) : Tyt = Replace( Tyt, " ", " " )
Tyt = Replace( Tyt, vbCRLF, "" ) : Tyt = Replace( Tyt, vbLF, "" ) : Tyt = Replace( Tyt, vbCR, "" )
Tyt = Tyt & " frei"
' Txt = Txt & vbCRLF & i & " " & SplitTst( i ) & " frei"
Txt = Txt & vbCRLF & "Nr. " & n & " => " & Tyt
ReDim Preserve SplitTxt( n ) : SplitTxt( n ) = Tyt : n = n + 1
' ReDim Preserve SplitTxt( n ) : SplitTxt( n ) = SplitTst( i ) : n = n + 1
' MsgBox SplitTst( i ), , "1530 :: " & n
End If
Next
n = n - 1
' HDD-Auswahl anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "Folgende Festplatten (Disks; HDDs) befinden sich auf diesem PC:" & vbCRLF & Txt & vbCRLF & vbCRLF
Txt = Txt & "Welche Festplatte soll neu partitioniert werden?" & vbCRLF
Txt = Txt & "ALLE Daten der Festplatte gehen verloren!"
n = 9
n = InputBox( Txt, "1542 :: " & Titel, "" )
If n = "" Then
MsgBox "Ungültige Eingabe!" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1544 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
' MsgBox n, , "1548 :: "
If IsNumeric( n ) Then
n = Int( n )
Else
MsgBox "Es sind nur Zahl als Eingabe möglich!" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1552 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
If n > n OR n < 0 Then
MsgBox "Die eingegebene Zahl (" & n & ") ist zu groß oder zu klein! (0-" & n & ")" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1557 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
' (künftige) Partitionierung erfragen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FromatPart = ""
DiskPartParm = "sel dis " & n & vbCRLF
DiskPartParm = DiskPartParm & "clean" & vbCRLF
Txt = vbTab & "Die Festplatte" & vbCRLF & vbCRLF & Trim( SplitTxt( n ) ) & " frei" & vbCRLF & vbCRLF & vbTab & "soll neu partitioniert werden . . ." & vbCRLF & vbCRLF
Txt = Txt & "Bitte die Laufwerksbuchstaben und die Größen der einzelnen Laufwerke (Partitionen) angeben!" & vbCRLF & vbCRLF
Txt = Txt & vbTab & """C:12 E:8 F:"" steht für: " & vbCRLF & "Lw. C: mit 12GB, Lw. E: mit 8GB, Lw. F: restliche GB (CD-Lw. wird D:)." & vbCRLF
Txt = Txt & vbTab & """C:12 D:"" steht für: " & vbCRLF & "Lw. C: mit 12GB, Lw. E: restliche GB (CD-Lw. wird E:)." & vbCRLF
Txt = Txt & vbTab & "Die Eingabe ""C:12"" steht für: " & vbCRLF & "Lw. C: mit 12GB, restliche GB ungenutzt (CD-Lw. wird D:)." & vbCRLF
Tst = " C:13 E:5 I:"
Tst = " C:12 E:15 J:"
Tst = " C:12 I:"
Tst = InputBox( Txt, "1576 :: " & Titel, Tst )
If Tst = "" Then
MsgBox "Ungültige Eingabe!" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1578 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
Tst = Trim( Tst ) : Tst = Replace( Tst, " ", " " ) : Tst = Replace( Tst, " ", " " ) : Tst = Replace( Tst, " ", " " )
Txt = "'Disk " & n & "' => " & SplitTxt( n ) & vbCRLF & vbCRLF
' Partitionierungs-Eingabe auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SplitTst = Split( Tst, " ", -1, 1) : n = 0
For i = LBound( SplitTst ) To UBound( SplitTst )
' Txt = Txt & vbCRLF & i & " " & SplitTst( i )
Tst = UCase( SplitTst( i ) )
PartName = Left( Tst, 1 ) ' das erste Zeichen; muss Lw. Buchstabe sein
PartSize = Mid( Tst, 3 ) ' alles ab 3. Zeichen; muss Größe in GB sein
' If Len( PartSize ) > 0 Then PartSize = " size=" & PartSize * 1024
' MsgBox "PartSize: '" & PartSize & "'" & vbCRLF & "PartName: '" & PartName & "'", , "1597 :: "
If Len( PartSize ) > 0 Then Txt = Txt & "Lw. " & PartName & " wird auf " & PartSize & " GByte gesetzt." & vbCRLF
If Len( PartSize ) = 0 Then Txt = Txt & "Lw. " & PartName & " erhält den (restlichen) freien Platz der Disk." & vbCRLF
If i = 0 Then
FromatPart = FromatPart & "format " & PartName & ": /FS:NTFS /Y /Q /X /V:LW_" & PartName & vbCRLF
If Len( PartSize ) > 0 Then PartSize = " size=" & PartSize * 1024
DiskPartParm = DiskPartParm & "cre par pri" & PartSize & " noerr" & vbCRLF
DiskPartParm = DiskPartParm & "ass letter=" & PartName & " noerr" & vbCRLF
DiskPartParm = DiskPartParm & "act" & vbCRLF
End If
If i = 1 Then
DiskPartParm = DiskPartParm & "cre par ext noerr" & vbCRLF
End If
If i > 0 Then
FromatPart = FromatPart & "format " & PartName & ": /FS:NTFS /Y /Q /X /V:LW_" & PartName & vbCRLF
If Len( PartSize ) > 0 Then PartSize = " size=" & PartSize * 1024
DiskPartParm = DiskPartParm & "cre par log" & PartSize & " noerr" & vbCRLF
DiskPartParm = DiskPartParm & "ass letter=" & PartName & " noerr" & vbCRLF
End If
Next
' FromatPart = FromatPart & "@pause&&@pause" & vbCRLF
fso.OpenTextFile( FormatCMD, 2, true).WriteLine( FromatPart )
fso.OpenTextFile( DiskPartDatei, 2, true).WriteLine( DiskPartParm )
' Kontrollfrage
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = MsgBox( "Partitionierung starten?" & vbCRLF & vbCRLF & Txt, vbYesNo + vbQuestion, "1626 :: " & Titel )
If Tst = vbYes Then
Tst = MsgBox( "Partitionierung wirklich starten?" & vbCRLF & vbCRLF & "ALLE Daten gehen verloren!", vbYesNo + 4096 + vbCritical + vbDefaultButton2, "1628 :: " & Titel )
If not ProgrVerz = "MININT" Then Tst = vbNo
If not Tst = vbYes Then
MsgBox "Abbruch der Partitionierung!", 4096 + vbInformation, "1631 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
fso.OpenTextFile( DiskPartDatei, 2, true).WriteLine( DiskPartParm )
' fso.OpenTextFile( "DISKPART.EXE /s """ & DiskPartDatei & """", 2, true).WriteLine( FromatPart )
' CreateObject("WScript.Shell").Run """" & "DISKPART.EXE /s """ & DiskPartDatei & """" & """", , False
Tst = ExecHiddenPlus( "DISKPART.EXE /s """ & DiskPartDatei & """" )
MsgBox Tst, , "1641 :: " & Titel
' fso.OpenTextFile( FormatCMD, 2, true).WriteLine( FromatPart )
CreateObject("WScript.Shell").Run """" & FormatCMD & """", , False
' Tst = ExecHiddenPlus( FormatCMD )
' MsgBox "Formatierung ist gestartet . . .", , "1646 :: " & Titel
Else
MsgBox "KEINE Partitionisreung!", vbInformation, "1648 :: " & Titel
End If
window.setTimeout "WIMBuRWIMInfoDaten()", 333
End Sub ' Partitionieren()
'*** 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 "1701 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "1702 :: " & Titel
End Function ' ArrayZeigen( InArray )
'***********************************************************
Sub RestoreZiel( VerzeichnisOderWim )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Trace32Log "1710 :: Anfang 'Sub RestoreZiel( " & VerzeichnisOderWim & " )'", 1
' MsgBox "VerzeichnisOderWim: '" & VerzeichnisOderWim & "'" , , "1711 :: "
VOW = VerzeichnisOderWim
If ProgrVerz = "MININT" Then ' bei WinPE
' Else
Trace32Log "1715 :: Aktuelles DatenZiel (für Restore): " & DatenZiel, 1
Trace32Log "1716 :: Verzeichnis-Auswahl (für Restore) wird gestartet . . . ", 1
' If VOW = "V" Then DatenZiel = BFFVerzAuswahl( "Verzeichnis für Restore auswählen:" )
If VOW = "W" Then DatenZiel = BFFAusWahlOCX( AktVerz, Left( fso.GetSpecialFolder( 0 ), 3 ), "wim" ) ' %windir%
If VOW = "V" Then DatenZiel = InputBox( "Bitte ein Laufwerk / Verzeichnis zur Datenwiederherstellung (Restore) eingeben:", "1719 :: " & Titel, "C:" ) : Trace32Log "1719 :: Neues DatenZiel (für Restore): '" & DatenZiel & "'", 1
Trace32Log "1720 :: Neues DatenZiel (für Restore): " & DatenZiel, 1
Else
Trace32Log "1722 :: Aktuelles DatenZiel (für Restore): " & DatenZiel, 1
Trace32Log "1723 :: Verzeichnis-Auswahl (für Restore) wird gestartet . . . ", 1
' ! If VOW = "V" Then DatenZiel = BFFVerzAuswahl( "Verzeichnis für Restore auswählen:" )
' If VOW = "W" Then DatenZiel = ChooseFile()
' ! If VOW = "W" Then DatenZiel = BFFAusWahlOCX( AktVerz, AktVerz, "wim" )
If VOW = "V" Then DatenZiel = BFFVerzAuswahl( "Verzeichnis für Restore auswählen:" ) : Trace32Log "1727 :: Neues DatenZiel (für Restore): '" & DatenZiel & "'", 1
If VOW = "W" Then DatenZiel = ChooseFile() : Trace32Log "1728 :: Neues DatenZiel (für Restore): '" & DatenZiel & "'", 1
Trace32Log "1729 :: Neues DatenZiel (für Restore): " & DatenZiel, 1
End If
Trace32Log "1732 :: Beendet 'Sub RestoreZiel()'", 1
Call WIMBuRRestore()
End Sub ' RestoreZiel( VerzeichnisOderWim )
'***********************************************************
Sub WIMBuRDelete()
'***********************************************************
Trace32Log "1739 :: Anfang 'Sub WIMBuRDelete()'", 1
MenueAkt = "DELETE"
document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> " & "1741 :: Die WIM-Informationen werden eingelesen. Bitte warten . . ."
window.setTimeout "WIMBuRWIMInfoDaten()", 333
Trace32Log "1743 :: Beendet 'Sub WIMBuRDelete()'", 1
End Sub ' WIMBuRDelete()
'***********************************************************
Sub WIMBuRWIMInfo()
'***********************************************************
Trace32Log "1749 :: Anfang 'Sub WIMBuRWIMInfo()'", 1
MenueAkt = "WIMINFO"
document.all.MenuRahmen.innerHTML = BuRWIMInfoMenue & "<br> " & "1751 :: Die WIM-Informationen werden eingelesen. Bitte warten . . ."
window.setTimeout "WIMBuRWIMInfoDaten()", 333
Trace32Log "1753 :: Beendet 'Sub WIMBuRWIMInfo()'", 1
End Sub ' WIMBuRWIMInfo
'***********************************************************
Sub ExportHTML()
'***********************************************************
' MsgBox "HTMLExport", , "1759 :: "
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim HtmDatei, errTst
HtmDatei = WIMGewaehlt & ".html"
On Error Resume Next
fso.OpenTextFile( HtmDatei, 2, True).WriteLine "Test"
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
HtmDatei = UserTempVerz & "\" & fso.GetFileName( WIMGewaehlt ) & ".html"
End If
' MsgBox HtmDatei, , "1772 :: "
XSLDateiSchreiben XSLDatei, "VBS"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1776 :: Datei geschrieben: " & XSLDatei, 1
XMLXSLalsHTML WIMGewaehlt, XSLDatei, XMLDatei, HtmDatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1780 :: Datei geschrieben: " & HtmDatei, 1
On Error Resume Next
CreateObject("WScript.Shell").Run """" & HtmDatei & """", , False
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
CreateObject("WScript.Shell").Run "mshta.exe """ & HtmDatei & """", , False
End If
End Sub ' ExportHTML()
'***********************************************************
Function WIMBuRWIMInfoDaten()
'***********************************************************
Trace32Log "1796 :: Anfang 'Function WIMBuRWIMInfoDaten()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, MenueAnz, ExeDauer
If MenueAkt = "BURINFO" Then MenueAnz = BuRInfoMenue
If MenueAkt = "BACKUP" Then MenueAnz = BuRBackupMenue
If MenueAkt = "RESTORE" Then MenueAnz = BuRRestoreMenue
If MenueAkt = "DELETE" Then MenueAnz = BuRDeleteMenue
If MenueAkt = "WIMINFO" Then MenueAnz = BuRWIMInfoMenue
' Enthält WIMGewaehlt einen Dateinamen?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1809 :: Aktuell WIMGewaehlt (Dateiname): '" & WIMGewaehlt & "'", 1
Trace32Log "1810 :: Prüfen ob WIMGewaehlt gültig . . .", 1
Tst = WIMGewaehlt
If not InStr( Tst, "\\" ) = 1 AND not InStr( Tst, ":\" ) = 2 Then
' MsgBox WIMGewaehlt & vbCRLF & vbCRLF & ". . . es kann also kein WIM geprüft werden.", vbCritical, "1813 :: " & Titel
document.all.MenuRahmen.innerHTML = MenueAnz & "<br> " & "1814 :: " & WIMGewaehlt & "</b><br><br> . . . es kann also kein WIM geprüft werden."
Trace32Log "1815 :: Aktuell WIMGewaehlt (Dateiname) nicht verwendbar: '" & WIMGewaehlt & "'", 2
Exit Function
End if
' Ist WIMGewaehlt erreichbar?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1821 :: Prüfen ob WIMGewaehlt erreichbar . . .", 1
If fso.FileExists( WIMGewaehlt ) Then
Else
' MsgBox "Die Datei ist nicht verfügbar bzw. nicht erreichbar:" & vbCRLF & vbCRLF & WIMGewaehlt, vbCritical, "1824 :: " & Titel
document.all.MenuRahmen.innerHTML = MenueAnz & "<br> " & "1825 :: <b>Die Datei ist nicht verfügbar bzw. nicht erreichbar:</b><br><br> " & WIMGewaehlt
Trace32Log "1826 :: Aktuell WIMGewaehlt nicht erreichbar: " & WIMGewaehlt, 2
Exit Function
End If
Trace32Log "1829 :: Aktuell WIMGewaehlt (Dateiname) erreichbar: '" & WIMGewaehlt & "'", 1
If not ProgrOK Then
MsgBox "If not ProgrExeErreichbar( ProgrExe )", , "1832 :: "
Exit Function
End If
Tst = fso.GetFile( WIMGewaehlt ).DateLastModified
Trace32Log "1837 :: Aktuell WIMGewaehlt Dateidatum: " & Tst, 1
If WIMDateiDatum = Tst Then
Trace32Log "1839 :: Aktuell WIMGewaehlt ist NICHT neu(er), muss nicht neu getestet werden", 1
' MsgBox WIMDateiDatum & vbCRLF & Tst, , "1840 :: "
Else
' MsgBox "HTMLTxt wir aus XSL und XML neu aufgebaut . . . " & vbCRLF & WIMDateiDatum & vbCRLF & Tst, , "1842 :: " & Titel
Trace32Log "1843 :: Aktuell WIMGewaehlt ist neuer als das zuletzt getestete: " & WIMDateiDatum, 1
WIMDateiDatum = Tst
Trace32Log "1845 :: HTMLTxt wird neu erstellt . . . ", 1
HTMLTxt = WIMNeuTesten( WIMGewaehlt )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1848 :: HTMLTxt ist neu: '" & HTMLTxt & "'", 1
End If
Trace32Log "1851 :: HTMLTxt wird komplettiert . . .", 1
Tst = "<span Style="" font-size: 3pt; ""><br></span>"
If DatenZiel = "" Then
Tst = Tst & "<input class=""InputSonst"" onClick=""RestoreZiel('V')"" type=""submit"" accesskey=""z"" value=""Ziel""> "
Tst = Tst & "Es ist kein <b>Ziel-Verzeichnis</b> für eine Datenwiederherstellung fest gelegt."
Else
Tst = Tst & "<input class=""InputSonst"" onClick=""RestoreZiel('V')"" type=""submit"" accesskey=""z"" value=""Ziel""> "
Tst = Tst & " """ & DatenZiel & """ "
End If
If GottModus Then Tst = Tst & "<br><input class=""InputExpert"" onClick=""RestoreZiel('W')"" type=""submit"" accesskey=""g"" value=""Ziel-WIM (g)"">"
' Tst = Tst & "<input class=""InputMini"" onClick=""RestoreZiel('W')"" type=""submit"" accesskey=""g"" value=""WIM als Ziel""> "
If GottModus Then Tst = Tst & "<br><input class=""InputExpert"" onClick=""Partitionieren"" type=""submit"" accesskey=""p"" value=""Disk-Partitionieren (p)"">"
' Tst = Tst & "<input class=""InputMini"" onClick=""Partitionieren"" type=""submit"" accesskey=""p"" value=""Disk-Partitionieren""> "
' Tst = Tst & "Es ist kein <b>Ziel-WIM</b> für eine Datenwiederherstellung fest gelegt."
Tst = Tst & "<br><br> <b> Mit der Auswahl eines Button wird das im WIM enthaltenen Image in den Zielpfad kopiert.</b><br><br>"
Txt = "<span Style="" font-size: 3pt; ""><br></span>"
Txt = Txt & "<input class=""InputSonst"" onClick=""ExportHTML()"" type=""submit"" accesskey=""e"" value=""Export""> "
Txt = Txt & "der Anzeige als HTML-Datei.<br>"
Txt = Txt & "<br><b> Mit der Auswahl eines Button werden Infos zu dem im WIM enthaltenen Image angezeigt.</b><br><br>"
If MenueAkt = "BURINFO" Then MenueAnz = BuRInfoMenue
If MenueAkt = "BACKUP" Then MenueAnz = BuRBackupMenue
If MenueAkt = "RESTORE" Then MenueAnz = BuRRestoreMenue & Tst
If MenueAkt = "DELETE" Then MenueAnz = BuRDeleteMenue & "<br><b> Mit dem Klick auf einen Button werden <u>nur die Verweise auf die Dateien</u> des Images im<br> WIM gelöscht, nicht jedoch die Datei(en) selbst - das WIM wird also nicht kleiner!</b><br><br>"
If MenueAkt = "WIMINFO" Then MenueAnz = BuRWIMInfoMenue & Txt
Trace32Log "1878 :: HTMLTxt ist komplett und wird angezeigt . . .", 1
document.all.MenuRahmen.innerHTML = MenueAnz & HTMLTxt
Trace32Log "1881 :: Beendet 'Function WIMBuRWIMInfoDaten()'", 1
End Function ' WIMBuRWIMInfoDaten()
'***********************************************************
Function WIMNeuTesten( WINDatei )
'***********************************************************
Trace32Log "1889 :: Anfang 'Function WIMNeuTesten( WINDatei )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim CmdBef, ExeDauer, Txt, Tst, Tyt, errTst
Dim CMDDatei : CMDDatei = CMDPfad & "_WIMTest.cmd"
Trace32Log "1896 :: Gebildete CMDDatei-Name: " & CMDDatei, 1
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ /XML /INFO """ & WINDatei & """>""" & XMLDatei & """"
If InStr( UCase( ProgrPara), "/CHECK" ) > 0 Then
CmdBef = """" & ProgrExe & """ /XML /CHECK /INFO """ & WINDatei & """>""" & XMLDatei & """"
End If
Trace32Log "1905 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
Tst = ""
If ProgrVerz = "MININT" AND fso.FolderExists( "X:\" ) Then
' bei WinPE als winpe.wim im RAM; %systemdrive%=X:
' es gibt keine Geschwindigkeitsvorteile!
Tyt = "X:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP X:" : fso.DeleteFile Tyt, True
End If
If ProgrVerz = "MININT" AND fso.FolderExists( "R:\" ) Then
' bei WinPE und %systemdrive%=X: und mit 'seperater' RAM-Disk R:
Tyt = "R:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP R:" : fso.DeleteFile Tyt, True
End If
CmdBef = Replace( CmdBef, " /INFO ", Tst & " /INFO " )
Trace32Log "1930 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' CMD-Zeilen in CMD-Datei schreiben und starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1935 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine CmdBef
Trace32Log "1937 :: Datei ist geschrieben: " & CMDDatei, 1
Trace32Log "1938 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
ExeDauer = Timer()
Tst = WSHShell.Run( """" & CMDDatei & """", 0, True )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' If ZeitTest = "Ja" Then MsgBox "WIM testen - ExeDauer: " & ( Timer() - ExeDauer ) & "s", , "1944 :: " & Titel
Trace32Log "1945 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
Trace32Log "1948 :: Datei soll erstellt werden: " & XSLDatei, 1
Trace32Log "1949 :: 'Call XSLDateiSchreiben( XSLDatei, ""HTA"" )' starten . . . ", 1
Call XSLDateiSchreiben( XSLDatei, "HTA" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1952 :: 'Call XSLDateiSchreiben( XSLDatei, ""HTA"" )' ist beendet.", 1
Trace32Log "1955 :: HTML-Daten erzeugen: " & XSLDatei, 1
Trace32Log "1956 :: 'XMLXSLalsHTML( WINDatei, XSLDatei, XMLDatei, HTMDatei )' starten (HTML-Daten erzeugen) . . . ", 1
WIMNeuTesten = XMLXSLalsHTML( WINDatei, XSLDatei, XMLDatei, "" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1959 :: 'XMLXSLalsHTML( WINDatei, XSLDatei, XMLDatei, HTMDatei )' ist beendet.", 1
Trace32Log "1962 :: Beendet 'Function WIMNeuTesten( WINDatei )'", 1
End Function ' WIMNeuTesten( WINDatei )
'*** 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()
'*** v10.B *** www.dieseyer.de *****************************
Function LinkErstellen( Zielverz, Beschr, Datei )
'***********************************************************
Dim Txt, Tst
Dim fso : Set fso = CreateObject( "Scripting.FileSystemObject" )
Dim WshShell : Set WshShell = CreateObject( "WScript.Shell" )
Tst = CreateObject("Scripting.FileSystemObject").GetSpecialFolder( 1 ) ' C:\Windows\System32
Dim ZielArg, ZielLink, IconPfad
Dim ZielAnw : ZielAnw = Datei
Txt = fso.GetExtensionName( UCase( Datei ) )
If Txt = "HTA" Then ZielAnw = Tst & "\mshta.exe" : ZielArg = """" & Datei & """"
If Txt = "VBS" Then ZielAnw = Tst & "\wscript.exe" : ZielArg = """" & Datei & """"
If Txt = "VBE" Then ZielAnw = Tst & "\wscript.exe" : ZielArg = """" & Datei & """"
If Txt = "CMD" Then ZielAnw = "%comspec%" : ZielArg = "/c """ & Datei & """"
If Txt = "BAT" Then ZielAnw = "%comspec%" : ZielArg = "/c """ & Datei & """"
Tst = Mid( Datei, 1, InStrRev( Datei, "." ) ) & "ico"
If fso.FileExists( Tst ) Then IconPfad = Tst
ZielLink = Zielverz & "\" & fso.GetBaseName( Datei ) & ".lnk" ' : MsgBox ZielLink, , "2016 :: "
' MsgBox "IconPfad: '" & IconPfad & "'" & vbCRLF & "Datei: '" & Datei & "'" & vbCRLF & "Zielverz: '" & Zielverz & "'" & vbCRLF & "ZielAnw: '" & ZielAnw & "'" & vbCRLF & "ZielArg: '" & ZielArg & "'" & vbCRLF & "ZielLink: '" & ZielLink & "'", 4096, "2018 :: "
Dim oShellLink : Set oShellLink = WshShell.CreateShortcut( ZielLink )
oShellLink.TargetPath = ZielAnw
oShellLink.Arguments = ZielArg
' oShellLink.WindowStyle = 1
' oShellLink.Hotkey = "CTRL+SHIFT+F"
If not IconPfad = "" Then
oShellLink.IconLocation = IconPfad
End If
oShellLink.Description = Beschr
' oShellLink.WorkingDirectory = Zielverz
oShellLink.WorkingDirectory = "%TEMP%"
On Error Resume Next
err.Clear
oShellLink.Save()
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
LinkErstellen = "Fehler: " & Tst
Tst = "Verknüpfung (Link, ShortCut) konnte nicht erstellt werden:" & vbCRLF & vbCRLF & Tst
' Tst = Tst & vbCRLF & vbCRLF & Zielverz & "\" & fso.GetBaseName( Datei ) & ".lnk"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll statt dessen eine Verknüpfung auf dem Desktopt erstellt werden?"
Tst = Replace( Tst, ":\\", ":\")
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2044 :: " & Titel )
If Tst = vbNo Then Exit Function
' CreateObject("Shell.Application").Namespace( 0 ).Self.Path => Desktop des aktuellen Users
Tst = LinkErstellen( CreateObject("Shell.Application").Namespace( 0 ).Self.Path, Beschr, Datei )
LinkErstellen = Tst
Exit Function
End If
LinkErstellen = ""
End Function ' LinkErstellen( Zielverz, Beschr, Datei )
'*** v10.8 *** www.dieseyer.de *****************************
Function BFFAusWahlOCX( AktVerz, StartVerz, DateiType )
'***********************************************************
' http://www.access-paradies.de/tipps/dateiauswahldialog.php
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Const OCXDatei = "comdlg32.ocx"
Const OCXDownLoad = "http://activex.microsoft.com/controls/vb5/comdlg32.cab"
Dim OCXPfad, Tst, errTst
OCXPfad = AktVerz & "\" & OCXDatei
On Error Resume Next
Tst = CreateObject("MSComDlg.CommonDialog")
errTst = err.Number & " - " & err.Description
On Error Goto 0
' MsgBox Tst & vbCRLF & errTst , , "2069 :: "
' If Len( errTst ) > 4 Then ' Nicht verfügbar: "MSComDlg.CommonDialog"
' OCXDatei registrieren
Trace32Log "2072 :: '" & errTst & "' / '" & Tst & "' nach CreateObject(""MSComDlg.CommonDialog"")", 1
If Left( errTst, 6 ) = "429 - " Then ' Nicht verfügbar: "MSComDlg.CommonDialog"
' MsgBox OCXPfad & vbCRLF & Tst & vbCRLF & errTst , , "2075 :: "
On Error Resume Next
Tst = CreateObject("Wscript.Shell").Run( "regsvr32.exe /s " & OCXPfad, 1, true )
errTst = err.Number & " - " & err.Description
On Error Goto 0
' MsgBox "VarType( " & Tst & " ) = " & VarType( Tst ) & " RC: '" & Tst & "'", , "2080 :: "
If Tst = 3 Then
Tst = "Fehler: '" & OCXPfad & "' nicht erreichbar!"
BFFAusWahlOCX = Tst
Trace32Log "2084 :: " & Tst, 3
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Diese Datei muss im '" & AktVerz & "'-Verzeichnise liegen!"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll der entspr. DownLoad von '" & OCXDownLoad & "' gestartet werden?"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "[Abbrechen] beendet '" & HTASelbst & "'."
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNoCancel, "2091 :: " & Titel )
If Tst = vbCancel Then self.close : BFFAusWahlOCX = "EXIT"
If Tst = vbYes Then CreateObject("Wscript.Shell").Run OCXDownLoad, , False
BFFAusWahlOCX = "EXIT"
Exit Function
End If
End If
If not Left( errTst, 6 ) = "394 - " Then ' bereits erledigt - kann nicht wiederholt werden: CreateObject("MSComDlg.CommonDialog")
On Error Resume Next
Tst = CreateObject("Wscript.Shell").Run( "regsvr32.exe /s " & OCXPfad, 1, true )
errTst = err.Number & " - " & err.Description
On Error Goto 0
Trace32Log "2104 :: '" & errTst & "' / '" & Tst & "' nach regsvr32.exe /s " & OCXPfad, 1
If Tst = 5 Then
Tst = "Fehler: '" & OCXDatei & "' kann nicht registriert werden."
Tst = "Fehler: '" & OCXPfad & "' kann nicht registriert werden."
BFFAusWahlOCX = Tst
Trace32Log "2109 :: " & Tst, 3
Trace32Log "2110 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Diese Datei muss im 'Administrator'-Kontext registriert werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte die Registrierung der " & OCXDatei & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2121 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
' MsgBox Tst & vbCRLF & errTst , , "2126 :: "
If not( errTst = "0 - " ) And (Len( errTst ) > 4 OR Tst = 3 ) Then
Tst = "Fehler: '" & OCXPfad & "' nicht erreichbar - " & errTst & " (" & Tst & ")"
BFFAusWahlOCX = Tst
Trace32Log "2130 :: " & Tst, 3
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Diese Datei muss im '" & AktVerz & "'-Verzeichnise liegen!"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2135 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
On Error Resume Next
Tst = CreateObject("WScript.Shell").RegWrite( "HKCR\Licenses\4D553650-6ABE-11cf-8ADB-00AA00C00905\", "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj", "REG_SZ" )
errTst = err.Number & " - " & err.Description
On Error Goto 0
' MsgBox Tst & vbCRLF & errTst , , "2144 :: "
Trace32Log "2145 :: '" & errTst & "' / '" & Tst & "' nach CreateObject(""WScript.Shell"").RegWrite ""HKCR\Licenses\...""", 1
If Len( errTst ) > 4 Then ' Nicht 'beschreibbar': HKCR\Licenses\...
Trace32Log "2147 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "'" & HTASelbst & "' muss im 'Administrator'-Kontext gestartet werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte die Registrierung der " & OCXDatei & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2158 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
End If
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings( "%ALLUSERSPROFILE%" ) ' : MsgBox Tst, , "2164 :: "
If fso.FolderExists( "R:\" ) Then Tst = "R:\Documents and Settings" ' : MsgBox Tst, , "2166 :: "
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst ' : MsgBox "Erstellt: " & Tst, , "2167 :: "
Tst = Tst & "\Default User" ' : MsgBox Tst, , "2169 :: "
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst ' : MsgBox "Erstellt: " & Tst, , "2170 :: "
' MsgBox Tst, , "2172 :: "
If fso.FolderExists( Tst ) Then
Tst = Tst & "\Desktop"
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst : Trace32Log "2175 :: Erstellt: " & Tst, 1 ' : MsgBox "Erstellt: " & vbCRLF & vbCRLF & Tst, , "2175 :: "
End If
If not Right( StartVerz, 1 ) = "\" Then StartVerz = StartVerz & "\"
' MsgBox "'" & StartVerz & "'", , "2179 :: "
DateiType = LCase( DateiType )
Dim objDialog : Set objDialog = CreateObject("MSComDlg.CommonDialog")
' objDialog.Filter = "Alle Dateien (*.*)*.*"
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim|Alle Dateien (*.*)|*.*"
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim"
objDialog.Filter = UCase( DateiType ) & "-Dateien (*." & DateiType & ")|*." & DateiType
' objDialog.Filter = "Textdateien (*.txt)|*.txt"
objDialog.DialogTitle = "2189 :: " & UCase( DateiType ) & " auswählen . . . "
objDialog.InitDir = StartVerz
objDialog.MaxFileSize = 256
' objDialog.Flags = &H4 + &H400
objDialog.Flags = &H80000 OR &H4 OR &H2000 ' + &H800 + &H8
' objDialog.Flags = &H2000 ' + &H800 + &H8
' objDialog.FilterIndex = 1
' cdlOFNAllowMultiselect &H200 Ermöglicht, dass im Listenfeld Dateiname mehrere Dateien ausgewählt werden.
' Die FileName-Eigenschaft gibt einen String zurück, der alle ausgewählten
' Dateinamen enthält (die Namen sind im String durch Leerzeichen voneinander getrennt).
' cdlOFNCreatePrompt &H2000 Fragt den Benutzer, ob eine Datei angelegt werden soll, die noch nicht existiert.
' Dieses Flag setzt automatisch die Flags cdlOFNPathMustExist und cdlOFNFileMustExist.
' cdlOFNExplorer &H80000 Verwendet das dem Explorer ähnliche Dialogfeld zum Öffnen von Dateien.
' cdlOFNExtensionDifferent &H400 Weist darauf hin, dass sich die Dateinamenerweiterung des zurückgegebenen Dateinamens
' von der in der DefaultExt-Eigenschaft angegebenen Erweiterung unterscheidet. Dieses
' Flag wird nicht gesetzt, wenn die DefaultExt-Eigenschaft Null enthält, wenn die
' Erweiterungen übereinstimmen, oder wenn die Datei keine Erweiterung hat. Man kann
' den Wert dieses Flags überprüfen, nachdem das Dialogfeld geschlossen wurde.
' cdlOFNFileMustExist &H1000 Die Benutzer dürfen nur Dateinamen eingeben, die existieren. Wenn dieses Flag gesetzt
' ist und der Benutzer gibt einen ungültigen Dateinamen ein, wird eine Warnung angezeigt.
' Dieses Flag setzt automatisch das Flag cdlOFNPathMustExist.
' cdlOFNHelpButton &H10 Zeigt die Hilfe-Schaltfläche für das Dialogfeld an.
' cdlOFNHideReadOnly &H4 Verbirgt das Kontrollkästchen Mit Schreibschutz öffnen.
' cdlOFNLongNames &H200000 Erlaubt lange Dateinamen.
' cdlOFNNoChangeDir &H8 Zwingt das Dialogfeld, das aktuelle Verzeichnis so zu setzen, wie es beim Öffnen des
' Dialogfelds gesetzt war.
' cdlOFNNoDereferenceLinks &H100000 Verbietet die Dereferenzierung von Shell-Links (auch als Shortcuts bezeichnet). Standardmäßig
' bewirkt die Auswahl eines Shell-Links, dass dieser von der Shell dereferenziert wird.
' cdlOFNNoLongNames &H40000 Verbietet lange Dateinamen.
' cdlOFNNoReadOnlyReturn &H8000 Spezifiziert, dass die zurückgegebene Datei das Attribut Read-Only nicht gesetzt hat und
' sich nicht in einem schreibgeschützten Verzeichnis befindet.
' cdlOFNNoValidate &H100 Erlaubt ungültige Zeichen im zurückgegebenen Dateinamen.
' cdlOFNOverwritePrompt &H2 Bewirkt, dass das Dialogfeld Speichern unter eine Warnung erzeugt, wenn der angegebene
' Dateiname bereits existiert. (Die Benutzer können dann wählen, ob die Datei überschrieben
' werden soll.)
' cdlOFNPathMustExist &H800 Die Benutzer dürfen nur gültige Pfade eingeben. Wenn dieses Flag gesetzt ist und die Benutzer
' einen ungültigen Pfad eingeben, erscheint eine Warnung.
' cdlOFNReadOnly &H1 Markiert das Kontrollkästchen Mit Schreibschutz öffnen, wenn das Dialogfeld erzeugt wird.
' Dieses Flag gibt außerdem den Status des Kontrollkästchens Mit Schreibschutz öffnen nach dem
' Schließen des Dialogfelds an.
' cdlOFNShareAware &H4000 Zeigt an, dass mögliche Freigabe-Fehler ignoriert werden.
objDialog.ShowOpen()
' intResult = objDialog.ShowOpen()
BFFAusWahlOCX = objDialog.Filename
Set objDialog = nothing
End Function ' BFFAusWahlOCX( AktVerz, StartVerz, DateiType )
'*** v10.8 *** www.dieseyer.de *****************************
Function BFFVerzDateitype( Verz, DateiType )
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
' http://www.coding-board.de/board/showthread.php?t=19261
' Set oFolder = oFSO.GetFolder("C:\")
' Exit Function
Dim Tst, Dialog
' neu in v10.8
On Error Resume Next
err.Clear
Set Dialog = CreateObject("UserAccounts.CommonDialog")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
BFFVerzDateitype = BFFAusWahlOCX( AktVerz, Verz, DateiType )
Exit Function
End If
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim|Alle Dateien (*.*)|*.*"
Dialog.Filter = """" & UCase( DateiType ) & """ Dateien|*." & DateiType & "|All Files|*.*" ' zeigt nur *.txt
Dialog.FilterIndex = 1
Dialog.InitialDir = Verz
Dialog.Flags = &H4 ' HIDEREADONLY
Dialog.ShowOpen
BFFVerzDateitype = Dialog.FileName
End Function ' BFFVerzDateitype( Verz, DateiType )
'*** v10.B *** www.dieseyer.de ******************************
Function BFFVerzAuswahl( Frage )
'***********************************************************
' u.a. http://blogs.msdn.com/gstemp/archive/2004/02/17/74868.aspx
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AppShell : Set AppShell = CreateObject("Shell.Application")
Dim objFolder : Set objFolder = AppShell.BrowseForFolder( 0, Frage, &H0010 + &H0020 + &H0001 )
Dim Tst
On Error Resume Next
BFFVerzAuswahl = objFolder.ParentFolder.ParseName( objFolder.Title ).Path
Tst = err.number
' MsgBox objFolder.Title & vbCRLF & Tst, , "2282 :: "
If Tst = 424 then
BFFVerzAuswahl = WSHShell.SpecialFolders( objFolder.Title )
End If
'On Error Goto 0
If InStr( objFolder.Title, ":" ) > 0 Then
BFFVerzAuswahl = Mid( objFolder.Title, InStr( objFolder.Title, ":" ) - 1, 2) ' & "\"
End If
If UCase( objFolder.Title ) = UCase( CreateObject("WScript.Network").Username ) Then
BFFVerzAuswahl = AppShell.Namespace( 40 ).Self.Path
End If
' MsgBox AppShell.Namespace( 40 ).Self.Path, , "2294 :: "
If InStr( objFolder.Title, "Eigene Dateien" ) > 0 Then
BFFVerzAuswahl = AppShell.Namespace( 5 ).Self.Path
End If
' MsgBox BFFVerzAuswahl, , "2300 :: "
End Function ' BFFVerzAuswahl( Frage )
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteSystemDrive( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %SystemDrive%; häufig C:
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLw " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLwOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLwDr " & Tst : Exit Function
RemoteSystemDrive = objOperatingSystem.SystemDrive
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
' RemoteSystemDrive = "%systemdrive%: " & RemoteSystemDrive
End Function ' RemoteSystemDrive( PCName )
'***********************************************************
Function XMLXSLalsHTML( Titel, DateiXSL, DateiXML, DateiHTM )
'***********************************************************
Dim Txt
Txt = Txt & vbCRLF & "Titel: " & vbTab & vbTab & Titel
Txt = Txt & vbCRLF & "DateiXSL: " & vbTab & DateiXSL
Txt = Txt & vbCRLF & "DateiXML: " & vbTab & DateiXML
Txt = Txt & vbCRLF & "DateiHTM: " & vbTab & "'" & DateiHTM & "'"
' MsgBox Txt, , "2347 :: "
Txt = ""
Txt = Txt & vbCRLF & "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">"
Txt = Txt & vbCRLF & "<html><head>"
Txt = Txt & vbCRLF & "</head><body style="" font-size:9Pt; font-weight:normal; font-family:verdana,arial,sans-serif"">"
Txt = Txt & vbCRLF & "<title>" & Mid( Titel, InStrRev( Titel, "\" ) + 1 ) & "</title>"
' es soll _eine_ HTML-Datei geschrieben werden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not DateiHTM = "" Then
' Txt = Txt & vbCRLF & "<h2> " & Titel & "</h2>"
Txt = Txt & vbCRLF & "<span style="" font-size:12Pt; font-weight:bold;"" > " & Titel & "</span><br><br>"
End If
Txt = Txt & vbCRLF & " Die letzte Änderung (an) der Datei """ & Mid( Titel, InStrRev( Titel, "\" ) + 1 ) & """ "
Txt = Txt & vbCRLF & " erfolgte am " & CreateObject("Scripting.FileSystemObject").GetFile( Titel ).DateLastModified & ".<br>"
Dim xslDoc
Set xslDoc = CreateObject("Microsoft.XMLDOM")
xslDoc.async = false
xslDoc.load( DateiXSL )
Dim xmlDoc
Set xmlDoc=CreateObject("Microsoft.XMLDOM")
xmlDoc.async=false
xmlDoc.load( DateiXML )
Txt = Txt & vbCRLF & xmlDoc.transformNode(xslDoc)
Set xmlDoc = nothing
Set xslDoc = nothing
Txt = Txt & vbCRLF & "</body></html>"
' es soll _keine_ HTML-Datei geschrieben werden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If DateiHTM = "" Then
XMLXSLalsHTML = Txt ' HTML-Code wird übergeben
Exit Function
End If
' HTML-Code vervollständigen für HTML-Datei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & vbCRLF & "<br><br><span style="" font-size:7Pt; "">"
' Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de"" ><b>" & WScript.ScriptName & "</b> • © 2010 by dieseyer • all rights reserved • <b>www.dieseyer.de</b></a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de/scr/wim-inhalt.vbs"" ><b>wim-inhalt.vbs</b></a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de/dse-impressum.html"" > • © 2010 by dieseyer • all rights reserved • </a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
Txt = Txt & vbCRLF & "</span>"
Txt = Txt & vbCRLF & "</body></html>"
' HTML-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("Scripting.FileSystemObject").OpenTextFile( DateiHTM, 2, True).Write Txt
End Function ' XMLXSLalsHTML( DateiXSL, DateiXML, DateiHTM )
'***********************************************************
Sub SubStart( Nr )
'***********************************************************
Trace32Log "2406 :: Anfang 'SubStart( " & Nr & " )'", 1
' MsgBox "Nr: " & vbTab & vbTab & Nr & vbCRLF & "MenueAkt: " & vbTab & MenueAkt, , "2407 :: " & Titel
' If MenueAkt = "BURINFO" Then Call SubBuRInfo( Nr )
' If MenueAkt = "BACKUP" Then Call SubBackup( Nr )
' If MenueAkt = "RESTORE" Then document.all.MenuRahmen.innerHTML = BuRRestoreMenue & "<br> " & "2413 :: Wiederherstellung der Daten aus dem <b>Image " & Nr & "</b> wird vorbereitet . . ."
If MenueAkt = "RESTORE" Then window.setTimeout "SubRestore( '" & Nr & "' )", 333
If MenueAkt = "DELETE" Then document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> " & "2416 :: Das Löschen des <b>Image " & Nr & "</b> im WIM wird vorbereitet . . . <br><br><br>" & HTMLTxt
If MenueAkt = "DELETE" Then window.setTimeout "SubDelete( '" & Nr & "' )", 333
If MenueAkt = "WIMINFO" Then document.all.MenuRahmen.innerHTML = BuRWIMInfoMenue & "<br> " & "2419 :: Die Dateiliste (DIR) des <b>Image " & Nr & "</b> im WIM wird erstellt . . .<br><br>" & HTMLTxt
If MenueAkt = "WIMINFO" Then window.setTimeout "SubWIMInfo( '" & Nr & "' )", 333
Trace32Log "2422 :: Beendet 'SubStart( Nr )'", 1
End Sub ' SubStart( Nr )
'***********************************************************
Sub SubRestore( Nr )
'***********************************************************
Trace32Log "2429 :: Anfang 'SubRestore( " & Nr & " )'", 1
' MsgBox "SubRestore( " & Nr & " )", , "2430 :: " & Titel
Dim T, Tst
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Tst = "'VOW' - Inhalt: alt '" & VOW & "'"
If VOW = "" AND fso.FolderExists( DatenZiel ) Then VOW = "V"
If VOW = "" AND fso.FileExists( DatenZiel ) Then VOW = "W"
Tst = Tst & " - neu '" & VOW & "'"
' MsgBox "DatenZiel: " & vbTab & DatenZiel & vbCRLF & vbCRLF & Tst, , "2439 :: "
Trace32Log "2441 :: " & Tst, 1
Trace32Log "2443 :: Aktuelles DatenZiel für Restore: '" & DatenZiel & "'", 1
' DatenZiel Prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Tst = fso.GetExtensionName( LCase( DatenZiel ) ) : Trace32Log "2449 :: Neues DatenZiel (für Restore) Erweiterung: '" & Tst & "'", 1
' If not fso.FolderExists( DatenZiel ) AND Tst = "wim" Then
' Trace32Log "2451 :: Neues DatenZiel (für Restore) erstellt: '" & DatenZiel & "'", 1
' If not fso.FileExists( DatenZiel ) Then
' fso.OpenTextFile( DatenZiel, 2, True).WriteLine "Wird ggf. von WIM-BuR.hta gelöscht"
' Trace32Log "2454 :: Neues DatenZiel (für Restore) erstellt: '" & DatenZiel & "'", 1
' Else
' Trace32Log "2456 :: Neues DatenZiel (für Restore) erstellt: '" & DatenZiel & "'", 1
' End If
' End If
'
Tst = fso.GetExtensionName( LCase( DatenZiel ) ) : Trace32Log "2460 :: Neues DatenZiel (für Restore) Erweiterung: '" & Tst & "'", 1
If fso.FolderExists( DatenZiel ) OR Tst = "wim" Then
Trace32Log "2462 :: DatenZiel (für Restore) wird 'akzepitert': '" & DatenZiel & "'", 1
Else
Trace32Log "2464 :: Aktuelles DatenZiel für Restore ist ungültig: '" & DatenZiel & "'", 2
MsgBox "Es wurde kein (gültiges) Ziel für eine Datenwiederherstellung ausgewählt.", vbInformation, "2465 :: " & Titel
Trace32Log "2466 :: Restore (Versuch) wird abgebrochen.", 1
' Call RestoreZiel( )
Exit Sub
End If
' ZielLw. formatieren?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( DatenZiel ) = 2 AND InStr( DatenZiel, ":" ) = 2 Then
Tst = MsgBox( "Soll " & DatenZiel & " noch 'schnell' (NTFS) formatiert werden?", vbQuestion + vbOKCancel, "2475 :: " & Titel )
If Tst = vbOK Then
Tst = "format " & DatenZiel & " /Y /V:" & Titel & " /Q /FS:NTFS"
InputBox Tst, Tst, Tst
Tst = CreateObject("Wscript.Shell").Run( Tst, 1, true )
Tst = "(NTFS-) Formatierung von " & DatenZiel & " beendet mit RC: " & Tst
MsgBox Tst, 4096 + vbInformation, "2481 :: " & Titel
Trace32Log Tst, 1
Else
Trace32Log "2484 :: Angebotene Formatierung von " & DatenZiel & " wurde nicht gestartet.", 1
End If
End If
' Kontrollfrage
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
T = "Soll das Image mit der Nr. """ & Nr & """ aus dem WIM" & vbCRLF & vbCRLF
T = T & WIMGewaehlt & vbCRLF & vbCRLF
T = T & "in dieses Ziel-Verzeichnis kopiert werden?" & vbCRLF & vbCRLF
T = T & "Ziel: " & DatenZiel & vbCRLF & vbCRLF
If VOW = "V" Then
T = T & "ACHTUNG: Evtl. vorhandene Dateien werden überschrieben!"
End If
Tst = MsgBox( T, vbQuestion + vbOKCancel, "2498 :: " & Titel )
If not Tst = vbOK Then
Trace32Log "2502 :: Benutzer-Abbruch für Restore", 2
MsgBox "Datenwiederherstellung wurde abgebrochen.", vbInformation, "2503 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
Trace32Log "2507 :: KEIN Benutzer-Abbruch für Restore", 1
document.all.MenuRahmen.innerHTML = BuRRestoreMenue & "<br> " & "2510 :: Der Inhalt des <b>Image " & Nr & "</b> im WIM wird nach " & DatenZiel & " kopiert . . ."
window.setTimeout "SubRestore2( '" & Nr & "' )", 333
Trace32Log "2513 :: Beendet 'SubRestore( Nr )'", 1
End Sub ' SubRestore( Nr )
'***********************************************************
Sub SubRestore2( Nr )
'***********************************************************
Trace32Log "2521 :: Anfang 'SubRestore2( " & Nr & " )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, errTst, CmdBef, ExeDauer, i
Dim CMDDatei : CMDDatei = CMDPfad & "_Restore.cmd"
Dim IXParam
Trace32Log "2529 :: 'DatenZiel': " & DatenZiel, 1
If VOW = "V" Then IXParam = "/APPLY" ' : MsgBox "IXParam: " & IXParam, , "2531 :: "
If VOW = "W" Then IXParam = "/EXPORT" ' : MsgBox "IXParam: " & IXParam, , "2532 :: "
If VOW = "W" AND fso.FileExists( DatenZiel ) Then
If fso.GetFile( DatenZiel ).Size < 50 Then
MsgBox DatenZiel & vbCRLF & "ist nur " & fso.GetFile( DatenZiel ).Size & "Byte groß und wird gelöscht.", vbInformation,"2535 :: " & Titel
fso.DeleteFile DatenZiel, True
Trace32Log "2537 :: 'DatenZiel' gelöscht, weil zu klein: " & DatenZiel, 1
' Ein WIM ohne Inhalt ist min 1,5 KByte groß
Else
' MsgBox DatenZiel & ": " & fso.GetFile( DatenZiel ).Size & "Bytes", , "2540 :: "
End If
End If
' If fso.FileExists( DatenZiel ) Then MsgBox DatenZiel & vbCRLF & "ist " & fso.GetFile( DatenZiel ).Size & "Byte groß - wird NICHT gelöscht!", vbInformation,"2543 :: " & Titel
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ "& IXParam &" /VERIFY """ & WIMGewaehlt & """ " & Nr & " """ & DatenZiel & """ "
If InStr( UCase( ProgrPara), "/CHECK" ) > 0 Then
CmdBef = """" & ProgrExe & """ " & IXParam & " /CHECK /VERIFY """ & WIMGewaehlt & """ " & Nr & " """ & DatenZiel & """ "
End If
Trace32Log "2551 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
Tst = ""
If ProgrVerz = "MININT" AND fso.FolderExists( "X:\" ) Then
' bei WinPE als winpe.wim im RAM; %systemdrive%=X:
' es gibt keine Geschwindigkeitsvorteile!
Tyt = "X:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
' If Len( errTst ) < 5 Then Tst = " /TEMP X:" : fso.DeleteFile Tyt, True
End If
If ProgrVerz = "MININT" AND fso.FolderExists( "R:\" ) Then
' bei WinPE und %systemdrive%=X: und mit 'seperater' RAM-Disk R:
Tyt = "R:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP R:" : fso.DeleteFile Tyt, True
End If
CmdBef = Replace( CmdBef, " /APPLY ", Tst & " /APPLY " )
Trace32Log "2576 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' CMD-Zeilen bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "@echo off"
Txt = Txt & vbCRLF & "cls"
Txt = Txt & vbCRLF & "@echo " & "2582 :: Start: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "2583 :: Start: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo " & "2584 :: " & CmdBef & ">>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo " & "2585 :: " & CmdBef
Txt = Txt & vbCRLF & "@" & CmdBef
Txt = Txt & vbCRLF & "@Set RC=%errorlevel%"
Txt = Txt & vbCRLF & "@echo " & "2588 :: Ende: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "2589 :: Ende: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo Ende: %0 - RC: %RC%"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" Color E4"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!!"
Txt = Txt & vbCRLF & "@echo."
If not ZeitTest = "Ja" Then
Txt = Txt & vbCRLF & "@pause && @pause"
End If
Txt = Txt & vbCRLF & "exit %RC%"
' CMD-Zeilen in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2603 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine Txt
Trace32Log "2605 :: Datei ist geschrieben: " & CMDDatei, 1
' CMD-Datei starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox CMDDatei & vbCRLF & vbCRLF & vbTab & "ist erstellt.", , "2609 :: " & Titel
Trace32Log "2610 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
ExeDauer = Timer()
i = WSHShell.Run( """" & CMDDatei & """", , True )
' MsgBox "RC: '" & i & "'", , "2614 :: "
If ZeitTest = "Ja" Then ExeDauer = vbCRLF & vbCRLF & "ExeDauer: " & ( Timer() - ExeDauer ) & "s"
If not ZeitTest = "Ja" Then ExeDauer = ""
Trace32Log "2618 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
Txt = " Der Inhalt des Image " & Nr & " im WIM " & vbCRLF & vbCRLF & WIMGewaehlt & vbCRLF & vbCRLF & " wurde nach " & vbCRLF & vbCRLF & DatenZiel & vbCRLF & vbCRLF & " kopiert."
Tst = 0
Select Case i
Case 0 Tst = vbInformation : Txt = Txt & ExeDauer
Case 1 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültige Befehlszeilenoption!"
Case 2 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": WIMGAPI-Fehler!"
Case 3 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültiges Konfigurationsskript!"
Case 4 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Zugriff verweigert, Administratorrechte erforderlich!"
End Select
MsgBox Txt, Tst + 4096, "2628 :: " & Titel
Trace32Log "2630 :: Beendet 'SubRestore2( Nr )'", 1
Call WIMBuRRestore()
End Sub ' SubRestore2( Nr )
'***********************************************************
Sub SubDelete( Nr )
'***********************************************************
Trace32Log "2640 :: Anfang 'SubDelete( " & Nr & " )'", 1
Dim T, Tst
T = "Soll das Image mit der Nr. """ & Nr & """ aus dem WIM" & vbCRLF & vbCRLF
T = T & WIMGewaehlt & vbCRLF & vbCRLF
T = T & "gelöscht werden?"
Trace32Log "2645 :: WIMGewaehlt: '" & WIMGewaehlt & "'", 1
Trace32Log "2646 :: Frage, ob Image mit Nr. " & Nr & " aus WIMGewaehlt gelöscht werden soll . . . ", 1
Tst = MsgBox( T, vbQuestion + vbOKCancel, "2647 :: " & Titel )
If not Tst = vbOK Then
Trace32Log "2650 :: Benutzer-Abbruch für Delete", 2
MsgBox "Löschen wurde abgebrochen.", vbInformation, "2651 :: " & Titel
Call WIMBuRDelete()
Exit Sub
End If
Trace32Log "2655 :: KEIN Benutzer-Abbruch für Delete", 1
document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> 0759 :: Das <b>Image " & Nr & "</b> im WIM wird gelöscht . . .<br><br><br>" & HTMLTxt
window.setTimeout "SubDelete2( '" & Nr & "' )", 333
Trace32Log "2660 :: Beendet 'SubDelete( Nr )'", 1
End Sub ' SubDelete( Nr )
'***********************************************************
Sub SubDelete2( Nr )
'***********************************************************
Trace32Log "2667 :: Anfang 'SubDelete2( " & Nr & " )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim Txt, Tst, CmdBef
Trace32Log "2671 :: WIMGewaehlt: '" & WIMGewaehlt & "'", 1
Trace32Log "2672 :: Image mit Nr. " & Nr & " wird aus WIMGewaehlt gelöscht . . . ", 1
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ /DELETE """ & WIMGewaehlt & """ " & Nr
If InStr( UCase( ProgrPara), "/CHECK" ) > 0 Then
CmdBef = """" & ProgrExe & """ /DELETE /CHECK """ & WIMGewaehlt & """ " & Nr
End If
Trace32Log "2681 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' Befehlszeile startn
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2686 :: ExecHiddenPlus( CmdBef ) wird gestartet . . . ", 1
Tst = ExecHiddenPlus( CmdBef )
Trace32Log "2688 :: ExecHiddenPlus( CmdBef ) ist beendet.", 1
' Befehlszeilen-Ausgaben auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Replace( Tst, vbCRLF, "²µ" ) ' ²µ wird als Platzhalter verwendet
Tst = Replace( Tst, vbCR, "" )
Tst = Replace( Tst, vbLF, "" )
Tst = Replace( Tst, "²µ²µ", "²µ" )
Tst = Replace( Tst, "²µ²µ", "²µ" )
If InStr( Tst, "²µ" ) = 1 Then Tst = Mid( Tst, 4 )
Tst = Replace( Tst, "²µ", vbCRLF ) ' : InputBox Tst, "2700 :: " & Titel, Tst
' Befehlszeilen-Ausgaben (formatiert) anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> " & "2705 :: " & Replace( Tst, vbCRLF, "<br> " )
MsgBox Tst, , "2706 :: " & Titel
Trace32Log "2708 :: Beendet 'SubDelete2( Nr )'", 1
Call WIMBuRDelete()
End Sub ' SubDelete2( Nr )
'***********************************************************
Sub SubWIMInfo( Nr )
'***********************************************************
' MsgBox "SubWIMInfo( " & Nr & " )" & vbCRLF & "DirDatei: " & vbTab & DirDatei, , "2718 :: " & Titel
Trace32Log "2719 :: Anfang 'SubWIMInfo( " & Nr & " )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim CmdBef, Txt, Tst
Dim CMDDatei : CMDDatei = CMDPfad & "_WIMImageInfo.cmd"
Trace32Log "2724 :: Gebildete CMDDatei-Name: " & CMDDatei, 1
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ /DIR """ & WIMGewaehlt & """ " & Nr & " >>""" & DirDatei & """"
Trace32Log "2730 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' Kopf in die Ausgabedatei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = HtaSelbst & " (Hta-Dateidatum: " & HtaDatum & "; " & CreateObject("Scripting.FileSystemObject").GetFile( HtaSelbst ).Size & ")"
Tst = "http://dieseyer.de/scr/WIM-BuR.hta (Hta-Dateidatum: " & HtaDatum & "; " & CreateObject("Scripting.FileSystemObject").GetFile( HtaSelbst ).Size & " Bytes)"
Tst = Tst & vbCRLF
Tst = Tst & vbCRLF & "Diese Liste wurde durch folgende Befehlszeile erstellt:"
Tst = Tst & vbCRLF & CmdBef
Tst = Tst & vbCRLF
Tst = Tst & vbCRLF & "Folgende Dateien befinden sich im Image-Nr >>>" & Nr & "<<< des WIM"
Tst = Tst & vbCRLF & """" & WIMGewaehlt & """ "
Tst = Tst & vbCRLF & "WIM-Dateidatum: " & WIMDateiDatum
Tst = Tst & vbCRLF
Trace32Log "2745 :: Datei (Kopf für DirDatei) soll geschrieben werden: " & DirDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( DirDatei, 2, True).Write Tst
Trace32Log "2747 :: Datei (Kopf für DirDatei) ist geschrieben: " & DirDatei, 1
' CMD-Zeile in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2752 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine CmdBef
Trace32Log "2754 :: Datei ist geschrieben: " & CMDDatei, 1
' CMD-Datei starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2759 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
Tst = WSHShell.Run( """" & CMDDatei & """", 0, True )
Trace32Log "2761 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
' Ausgabedatei (DirDatei) mit NotePad anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2766 :: Ausgabedatei (DirDatei) soll mit NotePad angezeigt werden . . . ", 1
Txt = "CreateObject(""WScript.Shell"").Run 'notepad """ & DirDatei & """'"
window.setTimeout Txt, 1 * 333
Trace32Log "2769 :: Wird verzögert gestartet: " & Txt, 1
window.setTimeout "WIMBuRWIMInfo()", 6 * 333
Trace32Log "2772 :: Wird verzögert gestartet: " & Txt, 1
Trace32Log "2774 :: Beendet 'SubWIMInfo( Nr )'", 1
End Sub ' SubWIMInfo( Nr )
'***********************************************************
Sub XSLDateiSchreiben( XSLDatei, VOH )
'***********************************************************
' Diese Prozedur wird in
' http://dieseyer.de/scr/WIM-BuR.hta
' und
' http://dieseyer.de/scr/wim_inhalt.vbs
' verwendet - in der HTA-Version sind Buttons in der Anzeige
' erforderlich.
Dim T
' VOH - VBS oder HTA
' MsgBox VOH, , "2791 :: "
On Error Resume Next
If VOH = "" Then T = WScript.ScriptFullName
On Error GoTo 0
If VOH = "" AND InStr( T, "." ) > 0 Then VOH = "VBS"
If VOH = "" Then VOH = "HTA"
' MsgBox VOH, , "2797 :: "
T = "<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">"
T = T & vbCRLF & "<xsl:decimal-format name=""de"" decimal-separator="","" grouping-separator="".""/>"
T = T & vbCRLF & "<xsl:template match=""/"">"
T = T & vbCRLF & "<span style="" font-size:9Pt; font-weight:normal; font-family:verdana,arial,sans-serif"">"
T = T & vbCRLF & "<xsl:for-each select=""WIM"">"
T = T & vbCRLF & " WIM-Größe:"
T = T & vbCRLF & "<xsl:choose>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10995116277.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,0','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1099511627.776'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,00','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10737418.24'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1073741.824'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '104857.6'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,0','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10485.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,00','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:otherwise> <xsl:value-of select=""format-number(TOTALBYTES,'#.##0','de')"" /> Bytes</xsl:otherwise>"
T = T & vbCRLF & "</xsl:choose>; "
T = T & vbCRLF & "'<xsl:value-of select=""COMPRESSION"" />' Kompression; "
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "das WIM enthält "
T = T & vbCRLF & "<xsl:value-of select=""count(WIM/IMAGE/TOTALBYTES)"" />"
T = T & vbCRLF & "Images mit zusammen<br /> "
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES),'#.##0','de')"" /> Bytes ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.0009765625,'#.##0,0','de')"" /> kB ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.00000095367431640625,'#.##0,0','de')"" /> MB ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.000000000931322574615478515625,'#.##0,00','de')"" /> GB<br />"
T = T & vbCRLF & "<span style="" font-size:3Pt; height:2.5em; border:0px blue solid; width:98%; "" > <br /></span>"
T = T & vbCRLF & "<xsl:for-each select=""WIM/IMAGE"">"
T = T & vbCRLF & "<span style="" margin-left:-1px; margin-top:-1px; "
If VOH = "VBS" Then
T = T & vbCRLF & "height:3.5em; border:1px red solid; width:98%; padding:0.6em; float:left;"" >"
T = T & vbCRLF & "<xsl:value-of select=""@INDEX"" />. "
T = T & vbCRLF & "<b>""<xsl:value-of select=""NAME"" />""</b><br />"
T = T & vbCRLF & " Image enthält "
Else
T = T & vbCRLF & "height:5.6em; border:1px red solid; width:100%; padding:0.6em; float:left;"" >"
T = T & vbCRLF & "<span style="" font-size: 5Pt; font-weight: bold"" >"
T = T & vbCRLF & "<input type=""submit"" >"
T = T & vbCRLF & "<xsl:attribute name=""name""><xsl:value-of select=""@INDEX"" /></xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""value""><xsl:value-of select=""format-number(@INDEX,'000','de')"" /></xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""onClick"">SubStart('<xsl:value-of select=""@INDEX"" />')</xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""class"">InputNr</xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""accesskey""><xsl:value-of select=""@INDEX"" /></xsl:attribute>"
T = T & vbCRLF & "</input>"
T = T & vbCRLF & "</span>"
T = T & vbCRLF & " "
T = T & vbCRLF & "<b>""<xsl:value-of select=""NAME"" />""</b><br />"
T = T & vbCRLF & " "
T = T & vbCRLF & "enthält "
End If
T = T & vbCRLF & "<xsl:value-of select=""format-number(DIRCOUNT,'#.##0','de')"" /> Verzeichnis(se) und"
T = T & vbCRLF & "<xsl:value-of select=""format-number(FILECOUNT,'#.##0','de')"" /> Datei(en) "
T = T & vbCRLF & " in"
T = T & vbCRLF & "<xsl:choose>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10995116277.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,0','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1099511627.776'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,00','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10737418.24'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1073741.824'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '104857.6'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,0','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10485.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,00','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:otherwise> <xsl:value-of select=""format-number(TOTALBYTES,'#.##0','de')"" /> Bytes</xsl:otherwise>"
T = T & vbCRLF & "</xsl:choose>;<br />"
If VOH = "VBS" Then
T = T & vbCRLF & " "
Else
T = T & vbCRLF & " "
End If
T = T & vbCRLF & "<xsl:value-of select=""DESCRIPTION"" /> "
T = T & vbCRLF & "</span>"
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "<span style="" font-size:3Pt; height:2em; border:0px blue solid; width:98%; "" > <br /></span>"
T = T & vbCRLF & "<xsl:for-each select=""WIM"">"
T = T & vbCRLF & "<br /> GUID: <xsl:value-of select=""GUID"" /> "
T = T & vbCRLF & "(<xsl:value-of select=""PARTNUMBER"" /> - "
T = T & vbCRLF & "<xsl:value-of select=""TOTALPARTS"" /> - "
T = T & vbCRLF & "<xsl:value-of select=""ATTRIBUTES"" />) "
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "</span>"
T = T & vbCRLF & "</xsl:template>"
T = T & vbCRLF & "</xsl:stylesheet>"
If VOH = "VBS" Then
CreateObject("Scripting.FileSystemObject").OpenTextFile( XSLDatei, 2, True).Write T
Exit Sub
End If
Trace32Log "2883 :: Datei soll geschrieben werden: " & XSLDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( XSLDatei, 2, True).Write T
Trace32Log "2885 :: Datei ist geschrieben: " & XSLDatei, 1
Trace32Log "2887 :: Beendet 'XSLDateiSchreiben( XSLDatei )'", 1
End Sub ' XSLDateiSchreiben( XSLDatei, VOH )
'*** v10.B *** www.dieseyer.de *****************************
Function UserProfilVerz
'***********************************************************
' 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_UserProfile", "WQL", &h10 + &h20 )
Dim objItem, Tst
UserProfilVerz = ""
For Each objItem In colItems
If InStr( UCase( objItem.LocalPath ), UCase( CreateObject("WScript.Network").Username ) ) > 0 Then
UserProfilVerz = objItem.LocalPath
Exit For
End If
Next
Exit Function
' MsgBox UserProfilVerz & vbCRLF & UCase( CreateObject("WScript.Network").Username ), , "2909 :: "
If InStr( UCase( UserProfilVerz ), "%USERPROFILE%" ) = 1 Then
UserProfilVerz = Mid( UserProfilVerz, Len( "%USERPROFILE%" ) + 1 )
' UserProfilVerz = CreateObject("WScript.Shell").Environment("PROCESS")("USERPROFILE") & UserProfilVerz
End If
' MsgBox "UserProfilVerz: '" & UserProfilVerz & "'", , "2914 :: "
If UserProfilVerz = "" Then UserProfilVerz = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%")
' MsgBox "UserProfilVerz: '" & UserProfilVerz & "'", , "2917 :: "
If InStr( LCase( UserProfilVerz ), "%systemroot%" ) > 0 Then
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%systemroot%")
UserProfilVerz = Replace( LCase( UserProfilVerz ), "%systemroot%", Tst )
MsgBox "UserProfilVerz: '" & UserProfilVerz & "'", , "2922 :: "
End If
End Function ' UserProfilVerz
'*** v9.4 *** 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, Tst
UserTempVerz = ""
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, , "2944 :: "
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 & "'", , "2949 :: "
If UserTempVerz = "" Then UserTempVerz = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%")
' MsgBox "UserTempVerz: '" & UserTempVerz & "'", , "2952 :: "
If InStr( LCase( UserTempVerz ), "%systemroot%" ) > 0 Then
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%systemroot%")
UserTempVerz = Replace( LCase( UserTempVerz ), "%systemroot%", Tst )
' MsgBox "UserTempVerz: '" & UserTempVerz & "'", , "2957 :: "
End If
End Function ' UserTempVerz
'*** v9.4 *** www.dieseyer.de ******************************
Function ExecHiddenPlus( CMD )
'***********************************************************
Dim FileOut, oWsh, Tmp
Tmp = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
If CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
CreateObject("Scripting.FileSystemObject").DeleteFile Tmp, True
End If
If not CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
' zum Test nächste Zeile frei geben
' MsgBox Tmp & vbCRLF & vbCRLF & "F E H L T und wird deshalb neu geschrieben.", , "2978 :: " & Titel
Set FileOut = CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = """" " )
FileOut.WriteLine( " set oArgs = Wscript.Arguments " )
FileOut.WriteLine( " For i = 0 to oArgs.Count - 1 " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox oArgs.item(i) , , Titel & "" - oArgs "" " )
FileOut.WriteLine( " if Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & """""""" & oArgs.item(i) & """""""" & "" "" " )
FileOut.WriteLine( " if not Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & oArgs.item(i) & "" "" " )
FileOut.WriteLine( " Next " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox CMD , , Titel & "" Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec( CMD ) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ), , Titel & "" Ende "" " )
FileOut.Close
Set FileOuT = nothing
End If
Set oWsh = CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp & " " & CMD , 0, true
ExecHiddenPlus = oWsh.Environment("Volatile")( "Ergebnis" )
' zum Test nächste Zeile frei geben - Löschen der 'Tmp-Datei
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHiddenPlus( CMD )
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteWinDir( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %WINDIR% == %SYSTEMROOT%; häufig C:\Windows
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
Dim WindowsDirectory, SystemDirectory
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-Sys " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysDir " & Tst : Exit Function
WindowsDirectory = objOperatingSystem.WindowsDirectory
SystemDirectory = objOperatingSystem.SystemDirectory
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
If WindowsDirectory = "" Then
SystemDirectory = UCase( SystemDirectory )
If InStr( SystemDirectory, "\SYSTEM32" ) Then WindowsDirectory = Replace( SystemDirectory, "\SYSTEM32", "" )
End If
RemoteWinDir = WindowsDirectory
' RemoteWinDir = "%..root%: " & RemoteWinDir
End Function ' RemoteWinDir( PCName )
'*** 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()
'***********************************************************
Sub IcoAusHexDaten( ZielDatei, Txt )
'***********************************************************
Txt = "0000010001002020080000000000A8080000160000002800000020000000400000000100080000000000000400000000000000000000000000000000000000000000000080000080000000808000800000008000800080800000C0C0C000C0DCC000F0CAA6000020400000206000002080000020A0000020C0000020E00000400000004020000040400000406000004080000040A0000040C0000040E00000600000006020000060400000606000006080000060A0000060C0000060E00000800000008020000080400000806000008080000080A0000080C0000080E00000A0000000A0200000A0400000A0600000A0800000A0A00000A0C00000A0E00000C0000000C0200000C0400000C0600000C0800000C0A00000C0C00000C0E00000E0000000E0200000E0400000E0600000E0800000E0A00000E0C00000E0E00040000000400020004000400040006000400080004000A0004000C0004000E00040200000402020004020400040206000402080004020A0004020C0004020E00040400000404020004040400040406000404080004040A0004040C0004040E00040600000406020004060400040606000406080004060A0004060C0004060E00040800000408020004080400040806000408080004080A0004080C0004080E00040A0000040A0200040A0400040A0600040A0800040A0A00040A0C00040A0E00040C0000040C0200040C0400040C0600040C0800040C0A00040C0C00040C0E00040E0000040E0200040E0400040E0600040E0800040E0A00040E0C00040E0E00080000000800020008000400080006000800080008000A0008000C0008000E00080200000802020008020400080206000802080008020A0008020C0008020E00080400000804020008040400080406000804080008040A0008040C0008040E00080600000806020008060400080606000806080008060A0008060C0008060E00080800000808020008080400080806000808080008080A0008080C0008080E00080A0000080A0200080A0400080A0600080A0800080A0A00080A0C00080A0E00080C0000080C0200080C0400080C0600080C0800080C0A00080C0C00080C0E00080E0000080E0200080E0400080E0600080E0800080E0A00080E0C00080E0E000C0000000C0002000C0004000C0006000C0008000C000A000C000C000C000E000C0200000C0202000C0204000C0206000C0208000C020A000C020C000C020E000C0400000C0402000C0404000C0406000C0408000C040A000C040C000C040E000C0600000C0602000C0604000C0606000C0608000C060A000C060C000C060E000C0800000C0802000C0804000C0806000C0808000C080A000C080C000C080E000C0A00000C0A02000C0A04000C0A06000C0A08000C0A0A000C0A0C000C0A0E000C0C00000C0C02000C0C04000C0C06000C0C08000C0C0A000F0FBFF00A4A0A000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF008989898989898989898989898989898989898989898937378989898989892D3789898989898989898989898989898989898989898989373789898989895C372D898989898989898989898989898989898989898989893737898989895237374A8989898989898989898989898989898989898989898937378989894A37375B89898989898989898989898989895B373764493737898937378989522D376489898989898989898989898989895B3737373737373789893737373737373753898989898989898989898989898937375289895B373789893737373737373737374A89898989898989898989898937378989898937378989373789898989895B3764373737373737376452898989373789898989373789893737898989898989373737373737373737373752898937378989898937378989373789898989895B376537378989898989523765898937378989898937378989373737373737373737523737898989898989373789893737898989893737898937373737373737645289373789898989895337648989373789898989373789898989898989898989898937373737373737372D498989898989898989898989898989898989898989898937373737373737375289898989898989898989898989898989898989898989893737898989895237648989898989898989898989898989898989898989898989373789898989893737898989898989898989898989898989898989898989898937378989898952372D8989898989898989898989898989898989898989898989373737373737373752898989898989898989898989898989898989898989898937373737373765528989898989898989898989898989898989898989898989898989895B376489898965375B898989893737898937378989523752898937378989898965373789898937372D8989898937378989373789895B375B8989373789898949373737498949373737498989893737898937378989373737898937378989895237373752895237373753898989373789893737894A3737374A89373789898964375B375B895B375337648989893737898937378953375B3753893737898989372D493764896437892D3789898937378989373789652D892D65893737898952375B89373789372D895B3752898937378989373789375B895B3789373789895B3752895C3752375C8952375B898937378989373752375289523752373789892D37898953376537538989372D89893737898937375B37898989375B37378949376489895237373752898964374A8937378989373737648989896437373789533752898949373737498989523753893737898937373752898989523737378965374989898937373789898949376589373789893737374989898949373737890000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileOut, Tst, i
' Läßt sich die ZielDatei anlegen?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
Set FileOut = fso.OpenTextFile( ZielDatei, 2, True )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then Exit Sub
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 1
Do
FileOut.Write Chr( CInt( "&H" & Mid( Txt, i, 2 ) ) )
i = i + 2 : If i > Len( Txt ) Then Exit Do
Loop
FileOut.Close
Set FileOut = nothing
' MsgBox "{F5} folgt . . . ", , "3119 :: "
CreateObject("WScript.Shell").SendKeys "{F5}"
End Sub ' IcoAusHexDaten( ZielDatei, Txt )
'*** v9.5 *** www.dieseyer.de ******************************
Sub DateiTypRegistrieren( DateiTyp, Progr )
'***********************************************************
' in VBS und HTA verwendbar
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim ZielProgr : ZielProgr = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%")
If Left( UCase( ZielProgr ), 15 ) = "X:\I386\PROGRAM" Then ZielProgr = "R:" ' unter WinPE
: ZielProgr = ZielProgr & "\" & DSProgr & "\" & fso.GetFileName( Progr )
Dim Zielverz : Zielverz = fso.GetParentFolderName( ZielProgr )
Dim HilfsProgr : HilfsProgr = ""
If fso.GetExtensionName( LCase( Progr ) ) = "vbs" Then HilfsProgr = "wscript.exe "
If fso.GetExtensionName( LCase( Progr ) ) = "hta" Then HilfsProgr = "mshta.exe "
DateiTyp = LCase( DateiTyp )
Dim HKey, Txt, Tst
Trace32Log "3148 :: %ProgramFiles%: " & WSHShell.ExpandEnvironmentStrings("%ProgramFiles%"), 1
Trace32Log "3149 :: DateiTyp: " & DateiTyp, 1
Trace32Log "3150 :: Progr: " & Progr, 1
Trace32Log "3151 :: HilfsProgr: " & HilfsProgr, 1
Trace32Log "3152 :: DateiTyp: " & DateiTyp, 1
Trace32Log "3153 :: Zielverz: " & Zielverz, 1
Trace32Log "3154 :: ZielProgr: " & ZielProgr, 1
' Ziel-Verzeichnis für das Progr ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox Zielverz, , "3158 :: "
If fso.FolderExists( Zielverz ) Then
Else
Trace32Log "3161 :: Zielverz soll anlegt werden: " & Zielverz, 1
On Error Resume Next
fso.CreateFolder Zielverz
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Verzeichnis kann nicht ertellt werden:" & vbCRLF & vbCRLF & Tst & vbCRLF & vbCRLF & Zielverz
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "3168 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "3169 :: Verzeichnis kann nicht ertellt werden: " & Zielverz & " _ " & Tst, 3
Trace32Log "3170 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "3173 :: Erstellt: " & Zielverz & " _ " & Tst, 1
End If
End If
' Wenn Progr erreichbar, Prog ins Ziel-Verzeichnis kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn Progr NICHT erreichbar ist, wird davon ausgegangen,
' dass das Prog über die Umgebungsvariable PATH vom
' Betriebssystem gefunden wird.
If not fso.FileExists( Progr ) Then
ZielProgr = Progr
Trace32Log "3184 :: ZielProgr (evtl. neu) festgelegt: " & ZielProgr, 1
Else
Trace32Log "3186 :: Datei soll kopiert werden: (von..nach)", 1
Trace32Log "3187 :: " & Progr, 1
Trace32Log "3188 :: " & ZielProgr, 1
On Error Resume Next
fso.CopyFile Progr, ZielProgr, true
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Datei kann nicht ertellt werden:" & vbCRLF & vbCRLF & ZielProgr
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "3195 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "3196 :: Kann nicht erstellt werden: " & ZielProgr & " _ " & Tst, 3
Trace32Log "3197 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "3200 :: Erstellt: " & ZielProgr & " _ " & Tst, 1
End If
End If
' MsgBox ist64bit( "." ), , "3204 :: "
HKey = "HKLM\SOFTWARE\Classes"
If ist64bit( "." ) Then ' Win7 64Bit'
HKey = "HKCU\SOFTWARE\Classes"
End If
Txt = HKey & "\." & DateiTyp & "\"
WSHShell.RegWrite Txt, DateiTyp & "_auto_file"
Trace32Log "3212 :: RegWrite erfolgreich: " & Txt, 1
Txt = HKey & "\" & DateiTyp & "_auto_file\shell\open\command\"
WSHShell.RegWrite Txt, HilfsProgr & """" & ZielProgr & """ " & chr(34) & "%1" & chr(34)
Trace32Log "3216 :: RegWrite erfolgreich: " & Txt, 1
Txt = vbTab & ZielProgr & vbCRLF & vbCRLF
Txt = Txt & "wurde als Standard-Anwendung für '" & DateiTyp & "' -Dateien registriert." & vbCRLF & vbCRLF
Txt = Txt & "Künftig genügt es, eine Datei mit der Endung ." & DateiTyp & " doppelt an zu" & vbCRLF
Txt = Txt & "klicken und die Anwendung startet mit dieser Datei als Parameter. " & vbCRLF
WSHShell.PopUp Txt, 30, "3222 :: Sub 'DateiTypRegistrieren'", vbInformation
Trace32Log "3224 :: Ende - Sub 'DateiTypRegistrieren'", 1
End Sub ' DateiTypRegistrieren( DateiTyp, Progr )
'*** v10.C *** www.dieseyer.de *****************************
Function ist64bit( PC )
'***********************************************************
Dim objWMIService, colSettings, objOperatingSystem
Dim Tst
On Error resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colSettings
Tst = objOperatingSystem.OSArchitecture
If InStr( Tst, "64" ) = 1 Then ist64bit = True : Exit Function
Next
' If InStr( Tst, 64 ) = 1 Then ist64bit = True
ist64bit = False
End Function ' ist64bit( PC )
'***********************************************************
Sub document_onkeypress
'***********************************************************
Dim Tst
Tst = window.event.keyCode
If Len( LfdKey ) > 11 Then LfdKey = Mid( LfdKey, 2 )
LfdKey = LfdKey & Chr( Tst )
If InStr( LfdKey, "expert" ) Then GottModus = True : Call WIMBuRRestore() : LfdKey = ""
If InStr( LfdKey, "logdatei" ) Then
LfdKey = ""
CreateObject("WScript.Shell").Run "trace32.exe """ & LogDatei & """", , False
Tst = MsgBox( "Soll " & LogDatei & " gelöscht werden?", 4096 + vbYesNo, "3262 :: " &Titel )
If Tst = vbYes Then CreateObject("Scripting.FileSystemObject").DeleteFile LogDatei, True
End If
' document.all.ZeigeInfo.innerHTML = LfdKey & "3265 :: " & Len( LfdKey )
End Sub ' document_onkeypress
'*** 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, , "3354 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "3355 :: "
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()">
<span id="ZeigeInfo" ></span>
<span id="MenuEing"></span><br>
<span id="MenuRahmen" ></span>
<!--
<span id="InfoTxt" style="text-align: center; width: 642px; height: 3em; position: absolute; top: 478px; left: 11px; border: 2px solid red; background-color: #00d;"></span>
-->
</body>
</html>
#########################################################################
>>> wim-inhalt.vbs <<<
'*** v9.5 *** www.dieseyer.de ******************************
'
' Datei: wim_inhalt.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' zeigt den Inhalt von WIM-Dateien an, die mit IMAGEX.EXE
' erstellt wurden - vergl.
' http://technet.microsoft.com/de-de/library/cc722145.aspx
' Das VBS kann sich selbst als Standard-Anwendung für
' WIM-Dateien eintragen
'
' Das VBS benötigt zwingend
' IMAGEX.EXE
' und fragt ggf. nach dem Ort, wo sich diese Datei befindet.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim ProgrExe : ProgrExe = "IMAGEX.EXE"
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim AktVerz : AktVerz = Replace( WScript.ScriptFullName, WScript.ScriptName, "" ) ' "\" am Ende
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
LogDatei = AktVerz & fso.GetBaseName( WScript.ScriptFullName ) & ".log"
Dim TempVerz : TempVerz = UserTempVerz() & "\"
Dim XMLDatei : XMLDatei = TempVerz & fso.GetBaseName( WScript.ScriptFullName ) & ".xml"
Dim XSLDatei : XSLDatei = TempVerz & fso.GetBaseName( WScript.ScriptFullName ) & ".xsl"
Dim CMDDatei : CMDDatei = TempVerz & fso.GetBaseName( WScript.ScriptFullName ) & ".cmd"
Dim HTMDatei : HTMDatei = TempVerz & fso.GetBaseName( WScript.ScriptFullName ) & ".html"
Dim Titel : Titel = WScript.ScriptName
Dim Txt, Tst
Dim WIMDatei, ProgrOK
' 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, "047 :: " & WScript.ScriptName
Trace32Log "048 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "049 :: PCname: " & WSHNet.ComputerName, 1
Trace32Log "050 :: Angemeldeter User: " & WSHNet.UserName, 1
Trace32Log "052 :: AktVerz: " & AktVerz , 1
Trace32Log "053 :: LogDatei: " & LogDatei, 1
Trace32Log "054 :: TempVerz: " & TempVerz, 1
Trace32Log "055 :: XMLDatei: " & XMLDatei, 1
Trace32Log "056 :: XSLDatei: " & XSLDatei, 1
Trace32Log "057 :: CMDDatei: " & CMDDatei, 1
Trace32Log "058 :: HTMDatei: " & HTMDatei, 1
' Anzahl der Argumente testen - min. eins!
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count < 1 Then
Txt = "Das VBS " & Wscript.ScriptName & " benötigt einen WIM-Datei als Parameter!" & vbCRLF & vbCRLF
Txt = Txt & "[Ja]" & vbTab & vbTab & "öffnet den ""Datei-Auswahl-Dialog""." & vbCRLF & vbCRLF
Txt = Txt & "[Nein]" & vbTab & vbTab & "trägt dieses VBS als Standard-Anwendung" & vbCRLF & vbTab & vbTab & "für WIM-Dateien ein." & vbCRLF & vbCRLF
Txt = Txt & "[Abbruch]" & vbTab & "Alles lassen, wie es ist . . . " & vbCRLF & vbTab & vbTab & vbTab & ". . . bei ""Aaaaaaaangst""." & vbCRLF & vbCRLF
Tst = MsgBox( Txt, 4096 + vbQuestion + vbYesNoCancel, "067 :: " & WScript.ScriptName )
If Tst = vbYes Then WIMDatei = BFFVerzDateitype( "C:\", "wim" )
If Tst = vbNo Then DateiTypRegistrieren "Wim", WScript.ScriptFullName : WScript.Quit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Tst = vbCancel Then WSHShell.Popup " . . . dann eben nicht!", 10, "071 :: " & WScript.ScriptName & " . . . ist zu Ende.", 48 + 4096 : WScript.Quit
Else
WIMDatei = oArgs.item( 0 ) ' Der erste Parameter
Trace32Log "074 :: Als Prameter erhaltene WIM-Datei: " & WIMDatei, 1
End If
If Left( WIMDatei, 7 ) = "Fehler:" Then
Trace32Log "078 :: Ende " & WScript.ScriptFullName, 1
WScript.Quit
End If
Txt = WScript.ScriptName & vbCRLF & vbCRLF
Txt = Txt & "prüft jetz" & vbCRLF & vbCRLF
Txt = Txt & WIMDatei
Call PopsUp( Txt, 2 )
'MsgBox Txt, , "087 :: "
Trace32Log "089 :: Zu prüfende WIM-Datei: " & WIMDatei, 1
' Ist WIMDatei erreichbar?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FileExists( WIMDatei ) Then
Else
Txt = vbCRLF & vbCRLF & "Die Datei ist nicht erreichbar:" & vbCRLF & vbCRLF & WIMDatei
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "096 :: " & WScript.ScriptName, 4096 + vbCritical
Trace32Log "097 :: Kann nicht ausgeführt werden: " & ProgrExe & " _ " & Tst, 3
Trace32Log "098 :: Ende " & WScript.ScriptFullName, 1
WScript.Quit
End If
Trace32Log "101 :: WIM-Datei erreichbar: " & WIMDatei, 1
' Erreichbarkeit des Programms IMAGEX.EXE prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call ProgrExeErreichbar
' ' Erreichbarkeit des Programms IMAGEX.EXE prüfen
' ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' On Error Resume Next
' Tst = WSHShell.Run( ProgrExe, 0, True )
' Tst = err.Number & " - " & err.Description
' On Error GoTo 0
' If InStr( Tst, "2147024894" ) Then Tst = Tst & "Das System kann die angegebene Datei nicht finden."
' If Len( Tst ) > 4 Then
' Txt = vbCRLF & vbCRLF & "Programm kann nicht gestartet werden: " & vbCRLF & vbCRLF & vbTab & ProgrExe & vbCRLF & vbCRLF & Tst
' WSHShell.Popup vbTab & "= = = E N D E = = =" & Txt , 15, "116 :: " & WScript.ScriptName, 4096 + vbCritical
' Trace32Log "117 :: Kann nicht ausgeführt werden: " & ProgrExe & " _ " & Tst, 3
' Trace32Log "118 :: Ende " & WScript.ScriptFullName, 1
' WScript.Quit
' End If
' WIM-Datei prüfen und XML-Datei erzeugen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = ProgrExe & " /XML /CHECK /INFO """ & WIMDatei & """ > """ & XMLDatei & """"
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine Txt
Trace32Log "126 :: Geschrieben: " & CMDDatei, 1
Trace32Log "127 :: " & Txt, 1
WScript.Sleep 333
Trace32Log "131 :: Wird gestartet: " & CMDDatei, 1
Tst = WSHShell.Run( """" & CMDDatei & """", 0, True )
Trace32Log "135 :: Ist beendet: " & CMDDatei & "; RC: " & Tst, 1
XSLDateiSchreiben XSLDatei, ""
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "140 :: Datei geschrieben: " & XSLDatei, 1
XMLXSLalsHTML WIMDatei, XSLDatei, XMLDatei, HTMDatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "145 :: Datei geschrieben: " & HTMDatei, 1
' HTML-Datei - Name neu festlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Mid( WIMDatei, 1, InStrRev( WIMDatei, "." ) ) & "html"
Trace32Log "151 :: Als neue HTMDatei verwendbar: " & Txt & " ? ? ?", 1
If fso.FileExists( Txt ) Then
Trace32Log "153 :: Vorhandene wird gelöscht: " & Txt, 1
On Error Resume Next
fso.DeleteFile Txt
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Trace32Log "159 :: Kann nicht gelöscht werden: " & Txt & " _ " & Tst, 2
End If
End if
If fso.FileExists( Txt ) Then
Trace32Log "164 :: HTMDatei bleibt unverändert: " & HTMDatei, 1
Else
On Error Resume Next
fso.CopyFile HTMDatei, Txt, True
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Trace32Log "171 :: Kann nicht erstellt werden: " & Txt & " _ " & Tst, 2
Else
Trace32Log "173 :: Erfolgreich kopiert (von .. nach): " & HTMDatei, 1
Trace32Log "174 :: " & Txt, 1
Trace32Log "175 :: " & HTMDatei, 1
HTMDatei = Txt
End If
End if
WScript.Sleep 333
Trace32Log "182 :: Wird gestartet: " & HTMDatei, 1
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
CreateObject("WScript.Shell").Run """" & HtmDatei & """", , False
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
CreateObject("WScript.Shell").Run "mshta.exe """ & HtmDatei & """", , False
End If
Trace32Log "194 :: Ist gestartet: " & HTMDatei, 1
' WSHShell.Popup "= = = E N D E = = =", 2, "196 :: " & WScript.ScriptName
Trace32Log "198 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Wscript.Quit
'***********************************************************
Function XMLXSLalsHTML( Titel, DateiXSL, DateiXML, DateiHTM )
'***********************************************************
Dim Txt
Txt = Txt & vbCRLF & "Titel: " & vbTab & vbTab & Titel
Txt = Txt & vbCRLF & "DateiXSL: " & vbTab & DateiXSL
Txt = Txt & vbCRLF & "DateiXML: " & vbTab & DateiXML
Txt = Txt & vbCRLF & "DateiHTM: " & vbTab & "'" & DateiHTM & "'"
' MsgBox Txt, , "211 :: "
Txt = ""
Txt = Txt & vbCRLF & "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">"
Txt = Txt & vbCRLF & "<html><head>"
Txt = Txt & vbCRLF & "</head><body style="" font-size:9Pt; font-weight:normal; font-family:verdana,arial,sans-serif"">"
Txt = Txt & vbCRLF & "<title>" & Mid( Titel, InStrRev( Titel, "\" ) + 1 ) & "</title>"
' es soll _eine_ HTML-Datei geschrieben werden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not DateiHTM = "" Then
' Txt = Txt & vbCRLF & "<h2> " & Titel & "</h2>"
Txt = Txt & vbCRLF & "<span style="" font-size:12Pt; font-weight:bold;"" > " & Titel & "</span><br><br>"
End If
Txt = Txt & vbCRLF & " Die letzte Änderung (an) der Datei """ & Mid( Titel, InStrRev( Titel, "\" ) + 1 ) & """ "
Txt = Txt & vbCRLF & " erfolgte am " & CreateObject("Scripting.FileSystemObject").GetFile( Titel ).DateLastModified & ".<br>"
Dim xslDoc
Set xslDoc = CreateObject("Microsoft.XMLDOM")
xslDoc.async = false
xslDoc.load( DateiXSL )
Dim xmlDoc
Set xmlDoc=CreateObject("Microsoft.XMLDOM")
xmlDoc.async=false
xmlDoc.load( DateiXML )
Txt = Txt & vbCRLF & xmlDoc.transformNode(xslDoc)
Set xmlDoc = nothing
Set xslDoc = nothing
Txt = Txt & vbCRLF & "</body></html>"
' es soll _keine_ HTML-Datei geschrieben werden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If DateiHTM = "" Then
XMLXSLalsHTML = Txt ' HTML-Code wird übergeben
Exit Function
End If
' HTML-Code vervollständigen für HTML-Datei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & vbCRLF & "<br><br><span style="" font-size:7Pt; "">"
' Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de"" ><b>" & WScript.ScriptName & "</b> • © 2009 by dieseyer • all rights reserved • <b>www.dieseyer.de</b></a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de/scr/wim-inhalt.vbs"" ><b>wim-inhalt.vbs</b></a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de/dse-impressum.html"" > • © 2009 by dieseyer • all rights reserved • </a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
Txt = Txt & vbCRLF & "</span>"
Txt = Txt & vbCRLF & "</body></html>"
' HTML-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("Scripting.FileSystemObject").OpenTextFile( DateiHTM, 2, True).Write Txt
End Function ' XMLXSLalsHTML( DateiXSL, DateiXML, DateiHTM )
'***********************************************************
Sub XSLDateiSchreiben( XSLDatei, VOH )
'***********************************************************
' Diese Prozedur wird in
' http://dieseyer.de/scr/WIM-BuR.hta
' und
' http://dieseyer.de/scr/wim_inhalt.vbs
' verwendet - in der HTA-Version sind Buttons in der Anzeige
' erforderlich.
Dim T
' VOH - VBS oder HTA
' MsgBox VOH, , "279 :: "
On Error Resume Next
If VOH = "" Then T = WScript.ScriptFullName
On Error GoTo 0
If VOH = "" AND InStr( T, "." ) > 0 Then VOH = "VBS"
If VOH = "" Then VOH = "HTA"
' MsgBox VOH, , "285 :: "
T = "<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">"
T = T & vbCRLF & "<xsl:decimal-format name=""de"" decimal-separator="","" grouping-separator="".""/>"
T = T & vbCRLF & "<xsl:template match=""/"">"
T = T & vbCRLF & "<span style="" font-size:9Pt; font-weight:normal; font-family:verdana,arial,sans-serif"">"
T = T & vbCRLF & "<xsl:for-each select=""WIM"">"
T = T & vbCRLF & " WIM-Größe:"
T = T & vbCRLF & "<xsl:choose>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10995116277.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,0','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1099511627.776'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,00','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10737418.24'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1073741.824'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '104857.6'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,0','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10485.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,00','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:otherwise> <xsl:value-of select=""format-number(TOTALBYTES,'#.##0','de')"" /> Bytes</xsl:otherwise>"
T = T & vbCRLF & "</xsl:choose>; "
T = T & vbCRLF & "'<xsl:value-of select=""COMPRESSION"" />' Kompression; "
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "das WIM enthält "
T = T & vbCRLF & "<xsl:value-of select=""count(WIM/IMAGE/TOTALBYTES)"" />"
T = T & vbCRLF & "Images mit zusammen<br /> "
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES),'#.##0','de')"" /> Bytes ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.0009765625,'#.##0,0','de')"" /> kB ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.00000095367431640625,'#.##0,0','de')"" /> MB ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.000000000931322574615478515625,'#.##0,00','de')"" /> GB<br />"
T = T & vbCRLF & "<span style="" font-size:3Pt; height:2.5em; border:0px blue solid; width:98%; "" > <br /></span>"
T = T & vbCRLF & "<xsl:for-each select=""WIM/IMAGE"">"
T = T & vbCRLF & "<span style="" margin-left:-1px; margin-top:-1px; "
If VOH = "VBS" Then
T = T & vbCRLF & "height:3.5em; border:1px red solid; width:98%; padding:0.6em; float:left;"" >"
T = T & vbCRLF & "<xsl:value-of select=""@INDEX"" />. "
T = T & vbCRLF & "<b>""<xsl:value-of select=""NAME"" />""</b><br />"
T = T & vbCRLF & " Image enthält "
Else
T = T & vbCRLF & "height:5.6em; border:1px red solid; width:100%; padding:0.6em; float:left;"" >"
T = T & vbCRLF & "<span style="" font-size: 5Pt; font-weight: bold"" >"
T = T & vbCRLF & "<input type=""submit"" >"
T = T & vbCRLF & "<xsl:attribute name=""name""><xsl:value-of select=""@INDEX"" /></xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""value""><xsl:value-of select=""format-number(@INDEX,'000','de')"" /></xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""onClick"">SubStart('<xsl:value-of select=""@INDEX"" />')</xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""class"">InputNr</xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""accesskey""><xsl:value-of select=""@INDEX"" /></xsl:attribute>"
T = T & vbCRLF & "</input>"
T = T & vbCRLF & "</span>"
T = T & vbCRLF & " "
T = T & vbCRLF & "<b>""<xsl:value-of select=""NAME"" />""</b><br />"
T = T & vbCRLF & " "
T = T & vbCRLF & "enthält "
End If
T = T & vbCRLF & "<xsl:value-of select=""format-number(DIRCOUNT,'#.##0','de')"" /> Verzeichnis(se) und"
T = T & vbCRLF & "<xsl:value-of select=""format-number(FILECOUNT,'#.##0','de')"" /> Datei(en) "
T = T & vbCRLF & " in"
T = T & vbCRLF & "<xsl:choose>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10995116277.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,0','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1099511627.776'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,00','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10737418.24'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1073741.824'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '104857.6'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,0','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10485.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,00','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:otherwise> <xsl:value-of select=""format-number(TOTALBYTES,'#.##0','de')"" /> Bytes</xsl:otherwise>"
T = T & vbCRLF & "</xsl:choose>;<br />"
If VOH = "VBS" Then
T = T & vbCRLF & " "
Else
T = T & vbCRLF & " "
End If
T = T & vbCRLF & "<xsl:value-of select=""DESCRIPTION"" /> "
T = T & vbCRLF & "</span>"
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "<span style="" font-size:3Pt; height:2em; border:0px blue solid; width:98%; "" > <br /></span>"
T = T & vbCRLF & "<xsl:for-each select=""WIM"">"
T = T & vbCRLF & "<br /> GUID: <xsl:value-of select=""GUID"" /> "
T = T & vbCRLF & "(<xsl:value-of select=""PARTNUMBER"" /> - "
T = T & vbCRLF & "<xsl:value-of select=""TOTALPARTS"" /> - "
T = T & vbCRLF & "<xsl:value-of select=""ATTRIBUTES"" />) "
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "</span>"
T = T & vbCRLF & "</xsl:template>"
T = T & vbCRLF & "</xsl:stylesheet>"
If VOH = "VBS" Then
CreateObject("Scripting.FileSystemObject").OpenTextFile( XSLDatei, 2, True).Write T
Exit Sub
End If
Trace32Log "371 :: Datei soll geschrieben werden: " & XSLDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( XSLDatei, 2, True).Write T
Trace32Log "373 :: Datei ist geschrieben: " & XSLDatei, 1
Trace32Log "375 :: Beendet 'XSLDateiSchreiben( XSLDatei )'", 1
End Sub ' XSLDateiSchreiben( XSLDatei, VOH )
'*** v9.4 *** 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 : 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, , "394 :: "
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, , "400 :: " : WScript.Quit
End Function ' UserTempVerz
'*** v9.4 *** www.dieseyer.de ******************************
Function BFFStartVerzeichnis( Verz )
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
' http://www.coding-board.de/board/showthread.php?t=19261
' Set oFolder = oFSO.GetFolder("C:\")
Dim Dialog : Set Dialog = CreateObject("UserAccounts.CommonDialog")
Dialog.Filter = "WIM Files|*.wim|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 = 1 ' von den drei auswählbaren Filtern wird der 2. eingesetzt
Dialog.InitialDir = Verz
Dialog.Flags = &H4 ' HIDEREADONLY'
Dialog.ShowOpen
BFFStartVerzeichnis = Dialog.FileName
End Function ' BFFStartVerzeichnis( Verz )
'*** v9.5 *** www.dieseyer.de ******************************
Sub DateiTypRegistrieren( DateiTyp, Progr )
'***********************************************************
' in VBS und HTA verwendbar
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim ZielProgr : ZielProgr = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%") & "\dieseyer.de\" & fso.GetFileName( Progr )
Dim Zielverz : Zielverz = fso.GetParentFolderName( ZielProgr )
Dim HilfsProgr : HilfsProgr = ""
If fso.GetExtensionName( LCase( Progr ) ) = "vbs" Then HilfsProgr = "wscript.exe "
If fso.GetExtensionName( LCase( Progr ) ) = "hta" Then HilfsProgr = "mshta.exe "
DateiTyp = LCase( DateiTyp )
Dim Txt, Tst
Trace32Log "443 :: DateiTyp: " & DateiTyp, 1
Trace32Log "444 :: Progr: " & Progr, 1
Trace32Log "445 :: HilfsProgr: " & HilfsProgr, 1
Trace32Log "446 :: DateiTyp: " & DateiTyp, 1
Trace32Log "447 :: Zielverz: " & Zielverz, 1
' Ziel-Verzeichnis für das Progr ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FolderExists( Zielverz ) Then
Else
Trace32Log "453 :: Zielverz soll anlegt werden: " & Zielverz, 1
On Error Resume Next
fso.CreateFolder Zielverz
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Verzeichnis kann nicht ertellt werden:" & vbCRLF & vbCRLF & Tst
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "460 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "461 :: Verzeichnis kann nicht ertellt werden: " & Zielverz & " _ " & Tst, 3
Trace32Log "462 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "465 :: Erstellt: " & Zielverz & " _ " & Tst, 1
End If
End If
' Wenn Progr erreichbar, Prog ins Ziel-Verzeichnis kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn Progr NICHT erreichbar ist, wird davon ausgegangen,
' dass das Prog über die Umgebungsvariable PATH vom
' Betriebssystem gefunden wird.
If not fso.FileExists( Progr ) Then
ZielProgr = Progr
Trace32Log "476 :: ZielProgr (evtl. neu) festgelegt: " & ZielProgr, 1
Else
Trace32Log "478 :: Datei soll kopiert werden: (von..nach)", 1
Trace32Log "479 :: " & Progr, 1
Trace32Log "480 :: " & ZielProgr, 1
On Error Resume Next
fso.CopyFile Progr, ZielProgr, true
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Datei kann nicht ertellt werden:" & vbCRLF & vbCRLF & ZielProgr
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "487 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "488 :: Kann nicht erstellt werden: " & ZielProgr & " _ " & Tst, 3
Trace32Log "489 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "492 :: Erstellt: " & ZielProgr & " _ " & Tst, 1
End If
End If
Txt = "HKLM\SOFTWARE\Classes\." & DateiTyp & "\"
WSHShell.RegWrite Txt, DateiTyp & "_auto_file"
Trace32Log "498 :: RegWrite erfolgreich: " & Txt, 1
Txt = "HKLM\SOFTWARE\Classes\" & DateiTyp & "_auto_file\shell\open\command\"
WSHShell.RegWrite Txt, HilfsProgr & """" & ZielProgr & """ " & chr(34) & "%1" & chr(34)
Trace32Log "502 :: RegWrite erfolgreich: " & Txt, 1
Txt = vbTab & ZielProgr & vbCRLF & vbCRLF
Txt = Txt & "wurde als Standard-Anwendung für '" & DateiTyp & "' -Dateien registriert." & vbCRLF & vbCRLF
Txt = Txt & "Künftig genügt es, eine Datei mit der Endung ." & DateiTyp & " doppelt an zu" & vbCRLF
Txt = Txt & "klicken und die Anwendung startet mit dieser Datei als Parameter. " & vbCRLF
WSHShell.PopUp Txt, 30, "508 :: Sub 'DateiTypRegistrieren'", vbInformation
Trace32Log "510 :: Ende - Sub 'DateiTypRegistrieren'", 1
End Sub ' DateiTypRegistrieren( DateiTyp, Progr )
'***********************************************************
Function ProgrExeErreichbar
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim Txt, Tst
Txt = TempVerz & ProgrExe
If fso.FileExists( Txt ) Then ProgrExe = Txt : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Txt = AktVerz & ProgrExe
If fso.FileExists( Txt ) Then ProgrExe = Txt : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Txt = RemoteWinDir( "." ) & "\" & ProgrExe
If fso.FileExists( Txt ) Then ProgrExe = Txt : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Txt = RemoteWinDir( "." ) & "\System32\" & ProgrExe
If fso.FileExists( Txt ) Then ProgrExe = Txt : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Txt = RemoteWinDir( "." ) & "\SysWOW64\" & ProgrExe
If fso.FileExists( Txt ) Then ProgrExe = Txt : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
' Suchen-Dialog, weil imagex.exe nicht gefunden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = vbCRLF & vbCRLF & "Programm kann nicht gestartet werden bzw. ist nicht erreichbar: " & vbCRLF & vbCRLF & vbTab & ProgrExe & vbCRLF & vbCRLF & "Soll der Datei-Suchen-Dialog geöffnet werden?"
Tst = MsgBox( Txt, vbQuestion + vbYesNo, "540 :: " & Titel )
If Tst = vbYes Then
Txt = BFFVerzDateitype( AktVerz, "exe" )
Tst = InStrRev( Txt, "\" )
If Tst > 0 Then Tst = UCase( Mid( Txt, Tst + 1 ) )
If ProgrExe = Tst Then
ProgrExe = Txt
Txt = RemoteWinDir( "." ) & "\System32\" & Tst
ProgrExeErreichbar = vbTrue
ProgrOK = vbTrue
' document.all.InfoTxt.innerHTML = "550 :: " & "vbTrue" & " " & ProgrExe
Tst = MsgBox( ProgrExe & vbCRLF & vbCRLF & "in folgendes Verzeichnis kopieren:" & vbCRLF & vbCRLF & Txt, vbQuestion + vbYesNo, "551 :: " & Titel )
If Tst = vbYes Then
fso.CopyFile ProgrExe, Txt, True
ProgrExe = Txt
MsgBox "Erstellt: " & vbCRLF & vbCRLF & ProgrExe, vbInformation, "555 :: " & Titel
End If
Exit Function
End If
End If
' imagex.exe nicht gefunden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = vbCRLF & vbCRLF & "Programm kann nicht gestartet werden bzw. ist nicht erreichbar: " & vbCRLF & vbCRLF & vbTab & ProgrExe & vbCRLF & vbCRLF
WSHShell.Popup vbTab & "= = = F E H L E R = = =" & Txt , 15, "565 :: " & Titel, 4096 + vbCritical
ProgrOK = vbFalse
ProgrExeErreichbar = vbFalse
End Function ' ProgrExeErreichbar( Exe )
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteWinDir( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %WINDIR% == %SYSTEMROOT%; häufig C:\Windows
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
Dim WindowsDirectory, SystemDirectory
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-Sys " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysDir " & Tst : Exit Function
WindowsDirectory = objOperatingSystem.WindowsDirectory
SystemDirectory = objOperatingSystem.SystemDirectory
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
If WindowsDirectory = "" Then
SystemDirectory = UCase( SystemDirectory )
If InStr( SystemDirectory, "\SYSTEM32" ) Then WindowsDirectory = Replace( SystemDirectory, "\SYSTEM32", "" )
End If
RemoteWinDir = WindowsDirectory
' RemoteWinDir = "%..root%: " & RemoteWinDir
End Function ' RemoteWinDir( PCName )
'*** v10.8 *** www.dieseyer.de ******************************
Function BFFAusWahlOCX( StartVerz, DateiType )
'***********************************************************
' http://www.access-paradies.de/tipps/dateiauswahldialog.php
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tst
Tst = Replace( WScript.ScriptFullName, WScript.ScriptName, "" ) & "comdlg32.ocx"
If not fso.FileExists( Tst ) Then
MsgBox "Datei fehlt: " & vbCRLF & vbCRLF & Tst, 4096 + vbCritical, "625 :: " & Titel
BFFAusWahlOCX = "Fehler: '" & Tst & "' fehlt!"
Exit Function
Else
' MsgBox "Datei vorhanden: " & vbCRLF & vbCRLF & Tst, 4096 + vbInformation, "629 :: " & Titel
End If
On Error Resume Next
CreateObject("Wscript.Shell").Run "regsvr32.exe /s " & AktVerz & "\comdlg32.ocx", 1, true
On Error Goto 0
CreateObject("WScript.Shell").RegWrite "HKCR\Licenses\4D553650-6ABE-11cf-8ADB-00AA00C00905\", "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj", "REG_SZ"
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings( "%ALLUSERSPROFILE%" ) ' : MsgBox Tst, , "638 :: "
If fso.FolderExists( "R:\" ) Then Tst = "R:\Documents and Settings" ' : MsgBox Tst, , "640 :: "
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst ' : MsgBox "Erstellt: " & Tst, , "641 :: "
Tst = Tst & "\Default User" ' : MsgBox Tst, , "643 :: "
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst ' : MsgBox "Erstellt: " & Tst, , "644 :: "
' MsgBox Tst, , "646 :: "
If fso.FolderExists( Tst ) Then
Tst = Tst & "\Desktop"
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst : Trace32Log "649 :: Erstellt: " & Tst, 1 ' : MsgBox "Erstellt: " & vbCRLF & vbCRLF & Tst, , "649 :: "
End If
If not Right( StartVerz, 1 ) = "\" Then StartVerz = StartVerz & "\"
' MsgBox "'" & StartVerz & "'", , "653 :: "
DateiType = LCase( DateiType )
Dim objDialog : Set objDialog = CreateObject("MSComDlg.CommonDialog")
' objDialog.Filter = "Alle Dateien (*.*)*.*"
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim|Alle Dateien (*.*)|*.*"
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim"
objDialog.Filter = UCase( DateiType ) & "-Dateien (*." & DateiType & ")|*." & DateiType
' objDialog.Filter = "Textdateien (*.txt)|*.txt"
objDialog.DialogTitle = "663 :: " & UCase( DateiType ) & " auswählen . . . "
objDialog.InitDir = StartVerz
objDialog.MaxFileSize = 256
' objDialog.Flags = &H4 + &H400
objDialog.Flags = &H80000 OR &H4 OR &H2000 ' + &H800 + &H8
' objDialog.Flags = &H2000 ' + &H800 + &H8
' objDialog.FilterIndex = 1
' cdlOFNAllowMultiselect &H200 Ermöglicht, dass im Listenfeld Dateiname mehrere Dateien ausgewählt werden.
' Die FileName-Eigenschaft gibt einen String zurück, der alle ausgewählten
' Dateinamen enthält (die Namen sind im String durch Leerzeichen voneinander getrennt).
' cdlOFNCreatePrompt &H2000 Fragt den Benutzer, ob eine Datei angelegt werden soll, die noch nicht existiert.
' Dieses Flag setzt automatisch die Flags cdlOFNPathMustExist und cdlOFNFileMustExist.
' cdlOFNExplorer &H80000 Verwendet das dem Explorer ähnliche Dialogfeld zum Öffnen von Dateien.
' cdlOFNExtensionDifferent &H400 Weist darauf hin, dass sich die Dateinamenerweiterung des zurückgegebenen Dateinamens
' von der in der DefaultExt-Eigenschaft angegebenen Erweiterung unterscheidet. Dieses
' Flag wird nicht gesetzt, wenn die DefaultExt-Eigenschaft Null enthält, wenn die
' Erweiterungen übereinstimmen, oder wenn die Datei keine Erweiterung hat. Man kann
' den Wert dieses Flags überprüfen, nachdem das Dialogfeld geschlossen wurde.
' cdlOFNFileMustExist &H1000 Die Benutzer dürfen nur Dateinamen eingeben, die existieren. Wenn dieses Flag gesetzt
' ist und der Benutzer gibt einen ungültigen Dateinamen ein, wird eine Warnung angezeigt.
' Dieses Flag setzt automatisch das Flag cdlOFNPathMustExist.
' cdlOFNHelpButton &H10 Zeigt die Hilfe-Schaltfläche für das Dialogfeld an.
' cdlOFNHideReadOnly &H4 Verbirgt das Kontrollkästchen Mit Schreibschutz öffnen.
' cdlOFNLongNames &H200000 Erlaubt lange Dateinamen.
' cdlOFNNoChangeDir &H8 Zwingt das Dialogfeld, das aktuelle Verzeichnis so zu setzen, wie es beim Öffnen des
' Dialogfelds gesetzt war.
' cdlOFNNoDereferenceLinks &H100000 Verbietet die Dereferenzierung von Shell-Links (auch als Shortcuts bezeichnet). Standardmäßig
' bewirkt die Auswahl eines Shell-Links, dass dieser von der Shell dereferenziert wird.
' cdlOFNNoLongNames &H40000 Verbietet lange Dateinamen.
' cdlOFNNoReadOnlyReturn &H8000 Spezifiziert, dass die zurückgegebene Datei das Attribut Read-Only nicht gesetzt hat und
' sich nicht in einem schreibgeschützten Verzeichnis befindet.
' cdlOFNNoValidate &H100 Erlaubt ungültige Zeichen im zurückgegebenen Dateinamen.
' cdlOFNOverwritePrompt &H2 Bewirkt, dass das Dialogfeld Speichern unter eine Warnung erzeugt, wenn der angegebene
' Dateiname bereits existiert. (Die Benutzer können dann wählen, ob die Datei überschrieben
' werden soll.)
' cdlOFNPathMustExist &H800 Die Benutzer dürfen nur gültige Pfade eingeben. Wenn dieses Flag gesetzt ist und die Benutzer
' einen ungültigen Pfad eingeben, erscheint eine Warnung.
' cdlOFNReadOnly &H1 Markiert das Kontrollkästchen Mit Schreibschutz öffnen, wenn das Dialogfeld erzeugt wird.
' Dieses Flag gibt außerdem den Status des Kontrollkästchens Mit Schreibschutz öffnen nach dem
' Schließen des Dialogfelds an.
' cdlOFNShareAware &H4000 Zeigt an, dass mögliche Freigabe-Fehler ignoriert werden.
objDialog.ShowOpen()
' intResult = objDialog.ShowOpen()
BFFAusWahlOCX = objDialog.Filename
Set objDialog = nothing
End Function ' BFFAusWahlOCX( StartVerz, DateiType )
'*** v10.8 *** www.dieseyer.de *******************************
Function BFFVerzDateitype( Verz, DateiType )
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
' http://www.coding-board.de/board/showthread.php?t=19261
' Set oFolder = oFSO.GetFolder("C:\")
' Exit Function
Dim Tst, Dialog
' neu in v10.8
On Error Resume Next
err.Clear
Set Dialog = CreateObject("UserAccounts.CommonDialog")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
BFFVerzDateitype = BFFAusWahlOCX( Verz, DateiType )
Exit Function
End If
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim|Alle Dateien (*.*)|*.*"
Dialog.Filter = """" & UCase( DateiType ) & """ Dateien|*." & DateiType & "|All Files|*.*" ' zeigt nur *.txt
Dialog.FilterIndex = 1
Dialog.InitialDir = Verz
Dialog.Flags = &H4 ' HIDEREADONLY
Dialog.ShowOpen
BFFVerzDateitype = Dialog.FileName
End Function ' BFFVerzDateitype( Verz, DateiType )
'*** v9.5 *** www.dieseyer.de *******************************
Function PopsUp ( TxT, Dauer )
'************************************************************
' in VBS und HTA verwendbar
' ACHTUNG! Ausserhalb und vor dem ersten Aufruf dieser Prozedur
' muss einmal "Set Prog_PP = nothing" stehen, sonst wird es
' mit dem "prog.terminate" innerhalb der Prozedur nichts!
'
' ACHTUNG! Alle Variablen müssen ausserhalb dieser Prozedur
' deklariert werden (also folgende Zeilen an den Skript-Anfang):
' Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
' Set Prog_PP = nothing
Dim Fso_PP : Set Fso_PP = CreateObject("Scripting.FileSystemObject")
' VBSDatei_PP = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
Dim VBSDatei_PP : VBSDatei_PP = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
Dim FileOut_PP
On Error Resume Next
Prog_PP.terminate
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
If Txt = "" then
' On Error Resume Next
IF Fso_PP.FileExists(VBSDatei_PP) then Fso_PP.DeleteFile(VBSDatei_PP) ' löscht das MSG-VBScript
' On Error GoTo 0
Exit Function
End If
Txt = Replace( Txt, vbCRLF, """ & vbCRLF & """ )
Set FileOut_PP = Fso_PP.OpenTextFile(VBSDatei_PP, 2, true) ' MSG-VBScript öffnen mit neu anlegen
FileOut_PP.WriteLine "WScript.CreateObject(""WScript.Shell"").Popup """ & Txt & """ , " & Dauer & ", """ & Fso_PP.GetFileName( VBSDatei_PP ) & " "" , vbSystemModal "
' AKTIVvbs.WriteLine "WshShell.Popup Txt, 2, Titel, vbSystemModal "
FileOut_PP.Close
Set FileOut_PP = Nothing
Set Fso_PP = Nothing
On Error Resume Next
Set Prog_PP = CreateObject("WScript.Shell").exec( "WScript """ & VBSDatei_PP & """" )
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
End Function ' PopsUp ( TxT, Dauer )
'*** 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, , "875 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "876 :: "
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 )
#########################################################################
>>> winnt-or-win9x.vbs <<<
'v3.5***************************************************
' File: winnt-or-win9x.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'*******************************************************
' *****************************************************************
' etwas ausführlicher:
' *****************************************************************
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHEnvX = WSHShell.Environment("Process")
if WshEnvX("OS") = "Windows_NT" then
MsgBox "Windows_NT: NT4 oder W2k", , Titel
ScriptWeiter = "WinNT-XXX.vbs"
else
MsgBox "kein Windows_NT: Win9x, WinME", , Titel
ScriptWeiter = "Win9x-XXX.vbs"
end if
MsgBox ScriptWeiter, , WScript.ScriptName
' WshShell.run(ScriptWeiter)
' *****************************************************************
' ganz kurz:
' *****************************************************************
'
' Set WSHShell = WScript.CreateObject("WScript.Shell")
' Set WSHEnvX = WSHShell.Environment("Process")
' if WshEnvX("OS") = "Windows_NT" then WshShell.run("WinNT.VBS")
' if not WshEnvX("OS") = "Windows_NT" then WshShell.run("Win9x.VBS")
#########################################################################
>>> winverlogin.vbs <<<
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set WSHEnvX = WSHShell.Environment("Process")
Titel = WScript.ScriptName
if WshEnvX("OS") = "Windows_NT" then
MsgBox "Windows_NT: NT4 oder W2k", , Titel
ScriptWeiter = "WinNT-XXX.vbs"
else
MsgBox "kein Windows_NT: Win9x, WinME", , Titel
ScriptWeiter = "Win9x-XXX.vbs"
end if
MsgBox ScriptWeiter, , Titel
' WshShell.run(ScriptWeiter)
#########################################################################
>>> winversp-regread.vbs <<<
'v7.A**********************************************************
' File: winversp-regread.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt WindowsNT-Version und Sp-Version
'**************************************************************
Option Explicit
Dim Txt
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim oArgs : Set oArgs = Wscript.Arguments
Const KeyX = "HKLM\Software\Microsoft\Windows NT\CurrentVersion\"
' On Error Resume Next
Txt = Txt & vbCRLF & "ProductName: " & vbTab & vbTab & WSHShell.RegRead( KeyX & "ProductName" )
Txt = Txt & vbCRLF & "CSDVersion: " & vbTab & vbTab & WSHShell.RegRead( KeyX & "CSDVersion" )
Txt = Txt & vbCRLF & "CurrentVersion: " & vbTab & vbTab & WSHShell.RegRead( KeyX & "CurrentVersion" )
Txt = Txt & vbCRLF & "CurrentBuildNumber: " & vbTab & WSHShell.RegRead( KeyX & "CurrentBuildNumber" )
Txt = Txt & vbCRLF & "BuildLab: " & vbTab & vbTab & vbTab & WSHShell.RegRead( KeyX & "BuildLab" )
On Error GoTo 0
MsgBox Txt
#########################################################################
>>> winversp.vbs <<<
'v3.6***************************************************
' File: WinVerSP.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Programm ermittelt WindowsNT-Version und Sp-Version
'*******************************************************
Option Explicit
Dim WSHShell, FSO, WSHNet
Dim ObjRemote, RootKey, ObjReg, oVal
Dim Text, Text1, Text2, TextX, KeyX, Server
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHNet = WScript.CreateObject("WScript.Network")
If (fso.FileExists("REGOBJ.DLL")) Then ' Regobj.dll registrieren (erfordert AdminRechte)
TextX = "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" ' damit läßt sich besser auf die registry zugreifen
WshShell.Run (TextX),,TRUE ' muß im gleichen Verzeichnis wie das Script stehen
Set ObjReg = WScript.CreateObject("RegObj.Registry")
Else
MsgBox "REGSVR32.EXE " & "REGOBJ.DLL" & " /S" & vbTab & " konnte nicht aufgerufen werden!", , WScript.ScriptName
WScript.Quit
End If
Text1 = "Von welchem Computer soll das Betriebssystem ermittelt werden?"
Server = wshnet.ComputerName
Server = InputBox (Text1, WScript.ScriptName, Server)
If Server = "" then Server = InputBox (Text1, WScript.ScriptName)
If Server = "" then MsgBox " . . . denn eben nicht!", 64, WScript.ScriptName
If Server = "" then WScript.Quit
Server = UCase(Server)
Set ObjRemote = objReg.RemoteRegistry( Server ) ' Objekt auf (Remote-) PC zeigen (REGOBJ.DLL)
KeyX = "\HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion"
Text1 = ""
Text2 = ""
On Error Resume Next
Set RootKey = objRemote.RegKeyFromString(KeyX)
For Each oVal In RootKey.Values ' Auflistung Werte
if oVal.Name = "ProductName" then Text1 = oVal.Value
if oVal.Name = "CurrentVersion" then Text1 = "Windows NT " & oVal.Value
if oVal.Name = "CSDVersion" then Text2 = oVal.Value
Next
On Error GoTo 0
Text = "Der Computer " & vbTab & UCase(Server) & vbCRLF
Text = Text & "verwendet als Betriebssystem:" & vbCRLF & vbCRLF
Text = Text & Text1 & " " & Text2 & " " & vbCRLF
MsgBox Text, , WScript.ScriptName
Set ObjReg = nothing
WshShell.Run ("REGSVR32.EXE " & "REGOBJ.DLL" & " /U /S"),,TRUE ' REGOBJ.DLL - Registrierung aufheben
#########################################################################
>>> wmi-aktive-vbs.vbs <<<
'*** v6.7 *** www.dieseyer.de *******************************
'
' Datei: wmi-aktive-vbs.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur prüft, wie oft ein VBS mit einem bestimmten Name
' mit "wscript.exe" oder "cscript.exe" gerade läuft.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim TesteVBS, i
TesteVBS = "kleINES.vbs"
TesteVBS = WScript.ScriptFullName
MsgBox TesteVBS & " läuft " & AnzahlLaufendeVBS( TesteVBS ) & "x", , WScript.ScriptName
WScript.Quit
'**************************************************************
Function AnzahlLaufendeVBS( VBScripts )
'**************************************************************
' On Error Resume Next
AnzahlLaufendeVBS = 0
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
Dim strComputer : strComputer = "."
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
Dim objItem
For Each objItem In colItems
If InStr( LCase( objItem.CommandLine), LCase( VBScripts ) ) > 0 Then
If InStr( LCase( objItem.CommandLine ), "script.exe" ) > 0 Then
' Txt = Txt & vbCRLF & objItem.CommandLine
AnzahlLaufendeVBS = AnzahlLaufendeVBS + 1
End If
End If
Next
' MsgBox VBScripts & " läuft " & AnzahlLaufendeVBS & " mal!", , "Skriptende - " & WScript.ScriptName
End Function ' AnzahlLaufendeVBS( VBScripts )
#########################################################################
>>> wmi-biosserialnumber.vbs <<<
'*** v7.8 *** www.dieseyer.de *******************************
'
' Datei: wmi-biosserialnumber.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "Retrieving BIOS Information"
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox BIOSSN( "." ), , WScript.ScriptName
WScript.Quit
'*** v7.8 *** www.dieseyer.de *******************************
Function BIOSSN( PCName )
'************************************************************
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Dim colBIOS : Set colBIOS = objWMIService.ExecQuery ("Select * from Win32_BIOS")
Dim objBIOS
For each objBIOS in colBIOS
' Wscript.Echo "Build Number: " & objBIOS.BuildNumber
' Wscript.Echo "Current Language: " & objBIOS.CurrentLanguage
' Wscript.Echo "Installable Languages: " & objBIOS.InstallableLanguages
' Wscript.Echo "Manufacturer: " & objBIOS.Manufacturer
' Wscript.Echo "Name: " & objBIOS.Name
' Wscript.Echo "Primary BIOS: " & objBIOS.PrimaryBIOS
' Wscript.Echo "Release Date: " & objBIOS.ReleaseDate
' Wscript.Echo "Serial Number: " & objBIOS.SerialNumber
BIOSSN = objBIOS.SerialNumber
' Wscript.Echo "SMBIOS Version: " & objBIOS.SMBIOSBIOSVersion
' Wscript.Echo "SMBIOS Major Version: " & objBIOS.SMBIOSMajorVersion
' Wscript.Echo "SMBIOS Minor Version: " & objBIOS.SMBIOSMinorVersion
' Wscript.Echo "SMBIOS Present: " & objBIOS.SMBIOSPresent
' Wscript.Echo "Status: " & objBIOS.Status
' Wscript.Echo "Version: " & objBIOS.Version
' For i = 0 to Ubound(objBIOS.BiosCharacteristics)
' Wscript.Echo "BIOS Characteristics: " & _
' objBIOS.BiosCharacteristics(i)
' Next
Next
End Function ' BIOSSN()
#########################################################################
>>> wmi-druckerliste.vbs <<<
'5.A********************************************************
' File: wmi-druckerliste.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Listet alle Drucker, die am Computer definiert sind.
'
' Im wesentlichen aus
' http://www.microsoft.com/downloads/details.aspx?FamilyID=b4cb2678-dafb-4e30-b2da-b8814fe2da5a&DisplayLang=en
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim strComputer : strComputer = "."
MsgBox DrTest( strComputer ), , "13 :: " & WScript.ScriptName
MsgBox Win32Printer( strComputer ), , "15 :: " & WScript.ScriptName
MsgBox Win32PrinterCfg( strComputer ), , "17 :: " & WScript.ScriptName
WScript.Quit
'************************************************************
Function DrTest( strComputer )
'************************************************************
DrTest = ""
Dim objWMIService, colInstalledPrinters, objPrinter
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery ("Select * from Win32_Printer")
For Each objPrinter in colInstalledPrinters
' If InStr( UCase( objPrinter.Name ) , "\\S" ) Then DrTest = DrTest & ">; ; " & objPrinter.Name & vbCRLF
DrTest = DrTest & ">; ; " & objPrinter.Name & vbCRLF
Next
End Function' DrTestTest
'************************************************************
Function Win32Printer( strComputer )
'************************************************************
'On Error Resume Next
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Dim colItems : Set colItems = objWMIService.ExecQuery("Select * from Win32_Printer",,48)
Dim objItem
For Each objItem in colItems
If objItem.Default = True Then
Win32Printer = Win32Printer & objItem.Name & vbTab & objItem.Location & vbTab & "Standarddrucker" & vbCRLF
Else
Win32Printer = Win32Printer & objItem.Name & vbTab & objItem.Location & vbCRLF
End If
Next
End Function ' Win32Printer( strComputer )
'************************************************************
Function Win32PrinterCfg( strComputer )
'************************************************************
Dim Tst, Txt
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
' Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Dim colInstalledPrinters : Set colInstalledPrinters = objWMIService.ExecQuery ("Select * from Win32_PrinterConfiguration")
Dim objPrinter
For Each objPrinter in colInstalledPrinters
' If InStr( objPrinter.Name, "FinePrint" ) > 0 Then Txt = ""
Tst = Tst & vbCRLF & "Name: " & objPrinter.Name
Tst = Tst & vbCRLF & "Driver Version: " & objPrinter.DriverVersion
Tst = Tst & vbCRLF & "Duplex: " & objPrinter.Duplex
' Tst = Tst & vbCRLF & "Horizontal Resolution: " & objPrinter.HorizontalResolution
If objPrinter.Orientation = 1 Then
Txt = "Portrait"
Else
Txt = "Landscape"
End If
' Tst = Tst & vbCRLF & "Orientation : " & Txt
' Tst = Tst & vbCRLF & "Paper Length: " & objPrinter.PaperLength / 254
' Tst = Tst & vbCRLF & "Paper Width: " & objPrinter.PaperWidth / 254
' Tst = Tst & vbCRLF & "Print Quality: " & objPrinter.PrintQuality
' Tst = Tst & vbCRLF & "Scale: " & objPrinter.Scale
' Tst = Tst & vbCRLF & "Specification Version: " & objPrinter.SpecificationVersion
If objPrinter.TTOption = 1 Then
Txt = "Print TrueType fonts as graphics."
Elseif objPrinter.TTOption = 2 Then
Txt = "Download TrueType fonts as soft fonts."
Else
Txt = "Substitute device fonts for TrueType fonts."
End If
' Tst = Tst & vbCRLF & "True Type Option: " & Txt
Tst = Tst & vbCRLF & "Vertical Resolution: " & objPrinter.VerticalResolution
Tst = Tst & vbCRLF
Next
Win32PrinterCfg = Tst
End Function ' Win32PrinterCfg( strComputer )
#########################################################################
>>> wmi-ip-adresse.vbs <<<
'*** v7.9 *** www.dieseyer.de *******************************
'
' Datei: wmi-ip-adresse.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ermittelt mit WMI die IP-Adresse(n) eines PCs.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim oArgs : Set oArgs = Wscript.Arguments
Dim i, PCName
PCName = "." ' eigener PC
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
If i = 0 Then PCName = oArgs.item(i)
Next
MsgBox "==>" & wmiIPadr( PCName ) & "<==", , WScript.ScriptName ' mit Function Aufruf
' MsgBox "==>" & wmiIPadr( "MEINPC" ) & "<==", , WScript.ScriptName ' mit Function Aufruf
WScript.Quit
'*** v9.5 *** www.dieseyer.de *******************************
Function wmiIPadr( PCName )
'************************************************************
Dim objWMIService, IPConfig, Tst, i
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : wmiIPadr = "Fehler: WMI-IP " & Tst : Exit Function
Dim IPConfigSet : Set IPConfigSet = objWMIService.ExecQuery ("Select IPAddress from Win32_NetworkAdapterConfiguration where IPEnabled=TRUE")
wmiIPadr = ""
For Each IPConfig in IPConfigSet
If Not IsNull(IPConfig.IPAddress) Then
For i=LBound(IPConfig.IPAddress) to UBound(IPConfig.IPAddress)
If Len( wmiIPadr ) > 0 Then wmiIPadr = wmiIPadr & "; "
wmiIPadr = wmiIPadr & IPConfig.IPAddress(i)
Next
End If
Next
Set IPConfigSet = nothing
Set objWMIService = nothing
' wmiIPadr = "IP-Adr.: " & wmiIPadr
End Function ' wmiIPadr( PCName )
#########################################################################
>>> wmi-ipadr.vbs <<<
strComputer = "."
'On Error Resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_NTDomain")
For Each objItem in colItems
T = T & vbCRLF & "Client Site Name: " & objItem.ClientSiteName
T = T & vbCRLF & "DC Site Name: " & objItem.DcSiteName
T = T & vbCRLF & "Description: " & objItem.Description
T = T & vbCRLF & "DNS Forest Name: " & objItem.DnsForestName
T = T & vbCRLF & "Domain Controller Address: " & objItem.DomainControllerAddress
T = T & vbCRLF & "Domain Controller Address Type: " & objItem.DomainControllerAddressType
T = T & vbCRLF & "Domain Controller Name: " & objItem.DomainControllerName
T = T & vbCRLF & "Domain GUID: " & objItem.DomainGuid
T = T & vbCRLF & "Domain Name: " & objItem.DomainName
T = T & vbCRLF & "DS Directory Service Flag: " & objItem.DSDirectoryServiceFlag
T = T & vbCRLF & "DS DNS Controller Flag: " & objItem.DSDnsControllerFlag
T = T & vbCRLF & "DS DNS Domain Flag: " & objItem.DSDnsDomainFlag
T = T & vbCRLF & "DS DNS Forest Flag: " & objItem.DSDnsForestFlag
T = T & vbCRLF & "DS Global Catalog Flag: " & objItem.DSGlobalCatalogFlag
T = T & vbCRLF & "DS Kerberos Distribution Center Flag: " & objItem.DSKerberosDistributionCenterFlag
T = T & vbCRLF & "DS Primary Domain Controller Flag: " & objItem.DSPrimaryDomainControllerFlag
T = T & vbCRLF & "DS Time Service Flag: " & objItem.DSTimeServiceFlag
T = T & vbCRLF & "DS Writable Flag: " & objItem.DSWritableFlag
T = T & vbCRLF & "Name: " & objItem.Name
T = T & vbCRLF & "Primary Owner Contact: " & objItem.PrimaryOwnerContact
Next
MsgBox T
#########################################################################
>>> wmi-laufendemsiexec.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: wmi-laufendevbs.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur prüft, welche Skripte durch "wscript.exe"
' oder "cscript.exe" gerade laufen und fragt, ob eine davon
' beendet werden soll . . . um es dann zu beenden.
'
'************************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LogDatei, LogVerz, Tst
Tst = WshShell.ExpandEnvironmentStrings( WshShell.Environment("SYSTEM")("WINDIR") ) ' ergibt C:\WINDOWS
Tst = WshShell.ExpandEnvironmentStrings( "%WINDIR%") ' ergibt C:\WINDOWS
Tst = Tst & "\System32\CCM" : If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
Tst = Tst & "\Inst.LOG" : If not fso.FolderExists( Tst ) Then fso.CreateFolder( Tst )
LogVerz = Tst
LogDatei = Tst & "\" & fso.GetBaseName( WScript.ScriptName ) & ".log" ' : MsgBox "LogDatei: " & vbCRLF & LogDatei , , "024 :: "
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
' WSHShell.Popup "= = = S T A R T = = =", 2, "027 :: " & WScript.ScriptName
LogEintrag "028 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "029 :: LogDatei: " & LogDatei
LogEintrag "030 :: PCname: " & WSHNet.ComputerName
LogEintrag "031 :: Angemeldeter User: " & WSHNet.UserName
Dim i, PCName
PCName = WSHNet.ComputerName
' If not WMIpingOK( PCName ) Then MsgBox PCName & " ist nicht erreichbar.", , "038 :: " : WSCript.Quit
' If not WMIpingOK( PCName ) Then WSCript.Quit
' LogEintrag "041 :: " & PCName & " ist (per wmi-ping) erreichbar . . . "
' MsgBox PCName & " ist (per wmi-ping) erreichbar . . . ", , "042 :: "
Dim arrVbsLst
Do
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrVbsLst = LaufendeSkripte( PCName )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "050 :: UBound( arrVbsLst ): " & UBound( arrVbsLst )
LogEintrag "051 :: Anzahl der lafenden Skripte: " & UBound( arrVbsLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrVbsLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = " Welches Sckript soll beendet (kill) werden?" & vbCRLF
For i = LBound( arrVbsLst ) to UBound( arrVbsLst )
LogEintrag "059 :: " & i + 1 & " " & arrVbsLst( i )
Tst = Tst & vbCRLF & i + 1 & " " & arrVbsLst( i )
Next
WScript.Sleep 5*1000
Loop
WScript.Quit
i = InputBox( Tst, "069 :: " & WScript.ScriptName )
On Error Resume Next
i = Int( i )
On Error Resume Next
i = i - 1
If i < 0 OR i > UBound( arrVbsLst ) Then MsgBox "Falsche Eingabe!" & vbCRLF & vbCRLF & vbTab & "Skript-Ende.", , "075 :: " & WScript.ScriptName : WScript.Quit
LogEintrag "077 :: Soll beendet werden: " & arrVbsLst( i )
Tst = SkriptBeenden( PCName, arrVbsLst( i ) )
If not Tst Then LogEintrag "081 :: Konnte nicht beendet werden:" & arrVbsLst( i )
If not Tst Then MsgBox "Konnte nicht beendet werden:" & vbCRLF & vbCRLF & arrVbsLst( i ), , "082 :: " & WScript.ScriptName : WScript.Quit
If not Tst Then WScript.Quit
LogEintrag "085 :: Wurde beendet:" & arrVbsLst( i )
MsgBox "Wurde beendet:" & vbCRLF & vbCRLF & arrVbsLst( i ), , "086 :: " & WScript.ScriptName
WSHShell.Popup "= = = E N D E = = =", 2, "088 :: " & WScript.ScriptName
LogEintrag "089 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.A *** www.dieseyer.de *******************************
Function SkriptBeenden( PC, Progr )
'************************************************************
' On Error Resume Next
SkriptBeenden = False
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colProcessList : Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name Like '" & "%msiexec.exe%" & "'" ) ' : MsgBox colProcessList.Count, , "102 :: "
Dim objProcess
For Each objProcess in colProcessList
' MsgBox objProcess.CommandLine & vbCRLF & Progr, , "106 :: " ' : WScript.Quit
' If objProcess.CommandLine = Progr Then MsgBox objProcess.CommandLine & vbCRLF & Progr, , "107 :: " ' : WScript.Quit
If objProcess.CommandLine = Progr Then objProcess.Terminate() : SkriptBeenden = True
Next
' MsgBox i & " - PC: " & PC & vbCRLF & "Progr: " & Progr, , "111 :: "
End Function ' SkriptBeenden( PC )
'*** v7.A *** www.dieseyer.de *******************************
Function LaufendeSkripte( PC )
'************************************************************
' On Error Resume Next
Dim Txt, i
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
Dim objWMIService : ' Set objWMIService = GetObject("winmgmts:\\" & PC & "\root\CIMV2")
' Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
Dim objItem
For Each objItem In colItems
If InStr( LCase( objItem.CommandLine ), "msiexec.exe" ) > 0 Then
ReDim Preserve LaufendeSkripteX(i)
LaufendeSkripteX(i) = objItem.CommandLine
i = i + 1
End If
Next
Set colItems = nothing
Set objWMIService = nothing
LaufendeSkripte = LaufendeSkripteX
End Function ' LaufendeSkripte( PC )
'*** v6.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 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("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'*** 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 "212 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "213 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** 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 )
#########################################################################
>>> wmi-laufendevbs.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: wmi-laufendevbs.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur prüft, welche Skripte durch "wscript.exe"
' oder "cscript.exe" gerade laufen und fragt, ob eine davon
' beendet werden soll . . . um es dann zu beenden.
'
'************************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LfdProgrTxt, PCName, Ttt, Tyt, Tst, Txt, i
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Call LogEintrag( "" ) ' erstellt neue LogDatei
Call LogEintrag( " " ) ' fügt Leerzeile in LogDatei ein
WSHShell.Popup "= = = S T A R T = = =", 2, "026 :: " & WScript.ScriptName
LogEintrag "027 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "028 :: LogDatei: " & LogDatei
LogEintrag "029 :: PCname: " & WSHNet.ComputerName
LogEintrag "030 :: Angemeldeter User: " & WSHNet.UserName
PCName = WSHNet.ComputerName
If not WMIpingOK( PCName ) Then MsgBox PCName & " ist nicht erreichbar.", , "035 :: " : WSCript.Quit
If not WMIpingOK( PCName ) Then WSCript.Quit
LogEintrag "038 :: " & PCName & " ist (per wmi-ping) erreichbar . . . "
WSHShell.Popup PCName & " ist (per wmi-ping) erreichbar . . . ", 3, "039 :: " & WScript.ScriptName, 4096
Dim arrVbsLst
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arrVbsLst = LaufendeSkripte( PCName )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox "045 :: UBound( arrVbsLst ): " & UBound( arrVbsLst )
LogEintrag "046 :: Anzahl der lafenden Skripte: " & UBound( arrVbsLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ArrayZeigen( arrVbsLst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Array bearbeit - für eine 'bessere' Anzeige
For i = LBound( arrVbsLst ) to UBound( arrVbsLst )
ReDim Preserve arrVbsAnz( i )
Tst = arrVbsLst( i )
Tst = Mid( TSt, 1, InStr( Tst, "." ) + 3 ) ' bis ".exe"
Tst = Mid( Tst, InStrRev( Tst, "\" ) + 1 ) ' ab "\"; müsste jetzt "WScript.exe" sein
Txt = Tst
Tst = arrVbsLst( i )
Tst = Mid( Tst, InStr( Tst, Txt ) + Len( Txt ) + 3 ) ' alles nach "WScript.exe"
If Len( Tst ) < 55 Then
Txt = Txt & " " & Tst
Else
Ttt = Tst : Ttt = Mid( Ttt, 1, 30 ) ' die ersten Zeichen
If InStrRev( Ttt, "\" ) > 5 Then Ttt = Mid( Ttt, 1, InStrRev( Ttt, "\" ) )
Txt = Txt & " " & Ttt & " . . . "
Ttt = Tst : Ttt = Mid( Ttt, 30 ) ' die letzten Zeichen
If InStr( Ttt, "\" ) > 0 Then Ttt = Mid( Ttt, InStr( Ttt, "\" ) )
Txt = Txt & Ttt
End If
arrVbsAnz( i ) = Replace( Txt, """", "" )
Next
Tst = " Welches Skript soll beendet (kill) werden?" & vbCRLF
For i = LBound( arrVbsAnz ) to UBound( arrVbsAnz )
Tst = Tst & vbCRLF & i + 1 & ") " & arrVbsAnz( i )
Next
i = InputBox( Tst, "087 :: " & WScript.ScriptName )
On Error Resume Next
i = Int( i )
On Error Resume Next
i = i - 1
If i < 0 OR i > UBound( arrVbsLst ) Then MsgBox "Falsche Eingabe!" & vbCRLF & vbCRLF & vbTab & "Skript-Ende.", , "093 :: " & WScript.ScriptName : WScript.Quit
LogEintrag "095 :: Soll beendet werden: " & arrVbsLst( i )
Tst = SkriptBeenden( PCName, arrVbsLst( i ) )
If not Tst Then LogEintrag "099 :: Konnte nicht beendet werden:" & arrVbsLst( i )
If not Tst Then MsgBox "Konnte nicht beendet werden:" & vbCRLF & vbCRLF & arrVbsLst( i ), , "100 :: " & WScript.ScriptName : WScript.Quit
If not Tst Then WScript.Quit
LogEintrag "103 :: Wurde beendet:" & arrVbsLst( i )
WSHShell.Popup "Wurde beendet:" & vbCRLF & vbCRLF & arrVbsLst( i ), 3, "104 :: " & WScript.ScriptName, 4096
WSHShell.Popup "= = = E N D E = = =", 2, "106 :: " & WScript.ScriptName, 4096
LogEintrag "107 :: Ende " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
WScript.Quit
'*** v7.A *** www.dieseyer.de *******************************
Function SkriptBeenden( PC, Progr )
'************************************************************
' On Error Resume Next
SkriptBeenden = False
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colProcessList : Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name Like '" & "%script.exe%" & "'" ) ' : MsgBox colProcessList.Count, , "120 :: "
Dim objProcess
For Each objProcess in colProcessList
' MsgBox objProcess.CommandLine & vbCRLF & Progr, , "124 :: " ' : WScript.Quit
' If objProcess.CommandLine = Progr Then MsgBox objProcess.CommandLine & vbCRLF & Progr, , "125 :: " ' : WScript.Quit
If objProcess.CommandLine = Progr Then objProcess.Terminate() : SkriptBeenden = True
Next
' MsgBox i & " - PC: " & PC & vbCRLF & "Progr: " & Progr, , "129 :: "
End Function ' SkriptBeenden( PC )
'*** v7.A *** www.dieseyer.de *******************************
Function LaufendeSkripte( PC )
'************************************************************
' On Error Resume Next
Dim Txt, i
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
Dim objWMIService : ' Set objWMIService = GetObject("winmgmts:\\" & PC & "\root\CIMV2")
' Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
Dim objItem
For Each objItem In colItems
If InStr( LCase( objItem.CommandLine ), "script.exe" ) > 0 Then
ReDim Preserve LaufendeSkripteX(i)
LaufendeSkripteX(i) = objItem.CommandLine
i = i + 1
End If
Next
Set colItems = nothing
Set objWMIService = nothing
LaufendeSkripte = LaufendeSkripteX
End Function ' LaufendeSkripte( PC )
'*** v6.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 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("PCName " & PCName & " is not reachable")
WMIpingOK = False
End If
Next
Set objPing = Nothing
End Function ' WMIpingOK( PCName ) ' 6.2 - http://dieseyer.de
'*** 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 "230 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "231 :: " & WScript.ScriptName
End Function ' ArrayZeigen( InArray )
'*** 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 )
#########################################################################
>>> wmi-lfddienste.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: wmi-lfddienste.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' LfdDiensteLst()
' schreibt alle Dienste (mit allen 'Unter-Diensten') in eine
' .CSV-Datei. Die Prozedur verursacht einige 10s (20..60s)
' 100% CPU-Last.
'
'************************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Dim LfdProgrTxt, Tst, Ttt, Tyt, Nr
WSHShell.Popup "= = = S T A R T = = =", 2, "025 :: " & WScript.ScriptName
Trace32Log "026 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
Trace32Log "027 :: Log: " & LogDatei, 1
Trace32Log "028 :: PC: " & WSHNet.ComputerName, 1
Trace32Log "029 :: User: " & WSHNet.UserName, 1
Trace32Log "031 :: Wird gestartet: ""Call LfdDiensteLst()"" & (" & Timer() & ")", 1
Call LfdDiensteLst( "." ) ' Prozedur-Aufruf
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "038 :: Ist beendet: ""Call LfdDiensteLst()"" & (" & Timer() & ")", 1
WSHShell.Popup "= = = E N D E = = =", 2, "040 :: " & WScript.ScriptName
Trace32Log "041 :: Ende " & WScript.ScriptFullName, 1
Wscript.Quit
'*** v8.4 *** www.dieseyer.de *******************************
Function LfdDiensteLst( PC )
'************************************************************
' The Portable Script Center
' Version 3.0, November 2004
' "List Dependent Services for All Services"
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
LogDateiX = LogDateiX & ".csv"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Const ForAppending = 8
Dim objFSO : Set objFSO = CreateObject( "Scripting.FileSystemObject" )
Dim objLogFile : Set objLogFile = objFSO.OpenTextFile( LogDateiX, ForAppending, True )
objLogFile.Write( "Start Service Dependencies at " & now() & " on """ & PC & """ " )
objLogFile.Writeline
Dim objWMIService : Set objWMIService = GetObject( "winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2" )
Dim colListOfServices : Set colListOfServices = objWMIService.ExecQuery ( "Select * from Win32_Service" )
Dim objService, objServiceRegistryName, objServiceDisplayName, objDependentService, colServiceList
For Each objService in colListofServices
objServiceRegistryName = objService.Name
objServiceDisplayName = objService.DisplayName
Set colServiceList = objWMIService.ExecQuery( "Associators of {Win32_Service.Name='" & objServiceRegistryName & "'} Where AssocClass=Win32_DependentService Role=Antecedent" )
If colServiceList.Count = 0 then
objLogFile.Write( objServiceDisplayName ) & ";None"
objLogFile.Writeline
Else
For Each objDependentService in colServiceList
objLogFile.Write( objServiceDisplayName ) & ";"
objLogFile.Write( objDependentService.DisplayName )
Next
objLogFile.WriteLine
End If
Next
objLogFile.Write( "End Service Dependencies at " & now() & " on """ & PC & """ " )
objLogFile.Close
End Function ' LfdDiensteLst()
'*** 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 )
#########################################################################
>>> wmi-lfdprogramme.vbs <<<
'*** v8.4 *** www.dieseyer.de *******************************
'
' Datei: wmi-lfdprogramme.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Prozedur
' LfdProgrList()
' listet alle laufenden Programme / Prozesse. Die Prozedur
' ist in eine Do..Loop-Schleife eingebunden und wird dadurch
' innerhalb von 30min zu jeder vollen Minute aufgerufen.
' In die LOG-Datei erfolgen nur Einträge, wenn sich die Liste
' der laufenden Programme geändert hat.
'
'************************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LfdProgrTxt, Tst, Nr, i
' Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
' Trace32Log " - ", 0 ' erzeugt neue LOG-Datei
Trace32Log "026 :: Start " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )", 1
' Trace32Log "027 :: Log: " & LogDatei, 1
Trace32Log "028 :: PC: " & WSHNet.ComputerName, 1
Trace32Log "029 :: User: " & WSHNet.UserName, 1
Do
Nr = Nr + 1
' Trace32Log "034 :: " & Timer() & " - " & Timer() / 60 & " - " & FormatNumber( Timer() / 60, 4 ), 1
Tst = LfdProgrList() ' Prozedur-Aufruf
' Trace32Log "036 :: " & Timer() & " - " & Timer() / 60 & " - " & FormatNumber( Timer() / 60, 4 ), 1
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If LfdProgrTxt <> Tst Then ' Nur wenn sich die Liste der lfd. Programme geändert hatt
LfdProgrTxt = Tst ' Liste der lfd. Programme in eine LOG-datei schreiben (lassen)
Trace32Log "041 :: " & Nr & ": " & LfdProgrTxt, 1
End If
Do
Tst = Timer() / 60
Tst = FormatNumber( Timer() / 60, 4 )
If InStr( Tst, "0,00" ) > 0 Then Exit Do ' alle vollen 10min
If InStr( Tst, "1,00" ) > 0 Then Exit Do
If InStr( Tst, "2,00" ) > 0 Then Exit Do
If InStr( Tst, "3,00" ) > 0 Then Exit Do
If InStr( Tst, "4,00" ) > 0 Then Exit Do
If InStr( Tst, "5,00" ) > 0 Then Exit Do
If InStr( Tst, "6,00" ) > 0 Then Exit Do
If InStr( Tst, "7,00" ) > 0 Then Exit Do
If InStr( Tst, "8,00" ) > 0 Then Exit Do
If InStr( Tst, "9,00" ) > 0 Then Exit Do
WScript.Sleep 500
Loop
WScript.Sleep 500
If Nr > 30 Then Exit Do ' nach 30 durchläufen: Skript-Ende
Loop
Trace32Log "066 :: Ende " & WScript.ScriptFullName , 1
Wscript.Quit
'*** v8.4 *** www.dieseyer.de *******************************
Function LfdProgrList()
'************************************************************
Dim colItems : Set colItems = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery ("Select * from Win32_Process")
Dim objItems, objItem, i
For Each objItem in colItems
i = i + 1
' LfdProgrList = LfdProgrList & objItem.Name & vbTab
LfdProgrList = LfdProgrList & objItem.Name & """;"""
Next
LfdProgrList = i & """;""" & LfdProgrList
End Function ' LfdProgrList()
'*** 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 )
#########################################################################
>>> wmi-listservices.vbs <<<
'*** v3.9 *** www.dieseyer.de *******************************
'
' Datei: wmi-listservices.vbs
' Autor: Janke , DTC
' Auf: www.dieseyer.de
'
' Listet alle Services eines Rechners.
'
' (Leicht angepasst von dieseyer.)
'
'************************************************************
Computername = WScript.CreateObject("WScript.Network").ComputerName
ComputerName = InputBox("Für welchen Rechner?", WScript.ScriptName, ComputerName )
If ComputerName = "" then WScript.Quit
winmgmt1 = "winmgmts:{impersonationLevel=impersonate}!//" & ComputerName
Set ServSet = GetObject( winmgmt1 ).InstancesOf("Win32_service")
LogDatei now()
LogDatei ComputerName & " - Liste aller laufenden Services: "
for each Serv in ServSet
GetObject("winmgmts:").InstancesOf ("win32_service")
Text = Serv.Description & vbCRLF
Text = Text & vbTab & " Executable: " & Serv.PathName & vbCRLF
Text = Text & vbTab & " Status: " & Serv.Status & vbCRLF
Text = Text & vbTab & " State: " & Serv.State & vbCRLF
Text = Text & vbTab & " Start Mode: " & Serv.StartMode & vbCRLF
Text = Text & vbTab & " Start Name: " & Serv.StartName & vbCRLF
LogDatei Text
' MsgBox Text, , WScript.ScriptName
next
LogDatei now()
LogDateiAnzeige
WScript.Quit
'*********************************
Sub LogDatei (LogTxt) ' v3.9
'*********************************
WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile(WScript.ScriptName & ".log", 8, true).WriteLine (LogTxt)
End Sub ' LogDatei
'*********************************
Sub LogDateiAnzeige ' v3.9
'*********************************
WScript.CreateObject("WScript.Shell").run "notepad " & WScript.ScriptName & ".log"
End Sub ' LogDatei
#########################################################################
>>> wmi-netzwerkeigenschaften.vbs <<<
'v6.1*****************************************************
' File: wmi-netzwerkeigenschaften.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'
' Listet die Netzwerkeigenschaften von (remote) PCs.
' Protokoll am Besten mit baretail beobachten.
' (http://www.baremetalsoft.com/baretail/)
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim myFS : Set myFS = CreateObject("Scripting.FileSystemObject")
Dim myOutput : Set myOutput = myFS.OpenTextFile( "netzwerk.txt", 8, true ) ' 8 : erweitern, notfals anlegen'
Dim i, Tst
myOutput.WriteLine vbCRLF & String( 50, "-" ) & vbCRLF & WScript.ScriptName & " - Skripstart." & vbCRLF & String( 50, "-" )
For i = 20 to 22
Tst = "192.168.1." & i ' ergibt 192.168.1.20 . . . 192.168.1.22
myOutput.Write Tst & vbTab & " wird getestet . . . "
myOutput.Write Netzwerkinformationen( Tst )
Next
myOutput.WriteLine WScript.ScriptName & " - Skriptende." & vbCRLF
MsgBox "Skript - Ende", , WScript.ScriptName
WScript.Quit
'*********************************************************
Function Netzwerkinformationen( strComputer )
'*********************************************************
Dim objWMIService, objAdapter, colAdapters
Dim Ausgabe, i
on error resume next
'####################################################
'####### Script zum Ausgeben der #######
'####### Netzwerkeigenschaften #######
'####### 24.04.2003 Thumbs #######
'####################################################
Set objWMIService = GetObject ("winmgmts:" & "!\\" & strComputer & "\root\cimv2")
Netzwerkinformationen = strComputer & vbTab & " ist nicht erreichbar! " & now() & vbCRLF & vbCRLF
if err.Number <> 0 Then Exit Function ' PC ist nicht erreichbar
Set colAdapters = objWMIService.ExecQuery ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
Ausgabe = vbCRLF & now() & vbCRLF
For Each objAdapter in colAdapters
Ausgabe = Ausgabe & "=>> Host name: " & objAdapter.DNSHostName & vbCRLF
Ausgabe = Ausgabe & "DNS domain: " & objAdapter.DNSDomain & vbCRLF
Ausgabe = Ausgabe & "DNS suffix search list: " & objAdapter.DNSDomainSuffixSearchOrder & vbCr
Ausgabe = Ausgabe & "Description: " & objAdapter.Description & vbCRLF
Ausgabe = Ausgabe & "Physical address: " & objAdapter.MACAddress & vbCRLF
Ausgabe = Ausgabe & "DHCP enabled: " & objAdapter.DHCPEnabled & vbCRLF
If Not IsNull(objAdapter.IPAddress) Then
For i = LBound(objAdapter.IPAddress) To UBound(objAdapter.IPAddress)
Ausgabe = Ausgabe & "IP address: " & objAdapter.IPAddress(i) & vbCRLF
Next
End If
If Not IsNull(objAdapter.IPSubnet) Then
For i = LBound(objAdapter.IPSubnet) To UBound(objAdapter.IPSubnet)
Ausgabe = Ausgabe & "Subnet: " & objAdapter.IPSubnet(i) & vbCRLF
Next
End If
If Not IsNull(objAdapter.DefaultIPGateway) Then
For i = LBound(objAdapter.DefaultIPGateway) To UBound(objAdapter.DefaultIPGateway)
Ausgabe = Ausgabe & "Default gateway: " & objAdapter.DefaultIPGateway(i) & vbCRLF
Next
End If
Ausgabe = Ausgabe & "DHCP server: " & objAdapter.DHCPServer & vbCRLF
If Not IsNull(objAdapter.DNSServerSearchOrder) Then
For i = LBound(objAdapter.DNSServerSearchOrder) To UBound(objAdapter.DNSServerSearchOrder)
Ausgabe = Ausgabe & "DNS server: " & objAdapter.DNSServerSearchOrder(i) & vbCRLF
Next
End If
Ausgabe = Ausgabe & "Primary WINS server: " & objAdapter.WINSPrimaryServer & vbCRLF
Ausgabe = Ausgabe & "Secondary WINS server: " & objAdapter.WINSSecondaryServer & vbCRLF
Ausgabe = Ausgabe & "Lease obtained: " & objAdapter.DHCPLeaseObtained & vbCRLF
Ausgabe = Ausgabe & "Lease expires: " & objAdapter.DHCPLeaseExpires & vbCRLF
Next
Netzwerkinformationen = Ausgabe & vbCRLF
End Function ' Netzwerkinformationen( strComputer )
#########################################################################
>>> wmi-numlock-ein.vbs <<<
'v4.B***************************************************
' File: numlock-ein.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Das schaltet NumLock für den Anmeldedialog ein.
' Vergl. http://support.microsoft.com/?id=154529
'*******************************************************
Option Explicit
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Dim Txt, PCName, KeyPath, KeyKey, KeyInh, oReg
PCName = "."
PCName = WshNet.ComputerName
KeyPath = ".DEFAULT\Control Panel\Keyboard"
KeyKey = "InitialKeyboardIndicators"
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\default:StdRegProv")
oReg.GetExpandedStringValue HKEY_USERS,KeyPath,KeyKey,KeyInh
Txt = KeyInh
KeyInh = "2"
oReg.CreateKey HKEY_USERS,KeyPath
oReg.SetStringValue HKEY_USERS,KeyPath,KeyKey,KeyInh
oReg.GetExpandedStringValue HKEY_USERS,KeyPath,KeyKey,KeyInh
MsgBox "vorher:" & vbTab & Txt & vbCRLF & "nacher:" & vbTab & KeyInh, , PCName
WScript.Quit
#########################################################################
>>> wmi-pcname-aus-ipadr.vbs <<<
'*** v6.1 *** www.dieseyer.de *******************************
'
' Datei: wmi-pcname-aus-ipadr.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Ermittelt zu einer AP-Adresse per WMI den entspr. PC-Namen.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
' On Error Resume Next
Dim Tst : Tst = "192.168.1.19"
MsgBox Tst & " heißt " & PCname( Tst ) , , WScript.ScriptName
'*** v6.1 *** www.dieseyer.de *******************************
Function PCname( IPAdr )
'************************************************************
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
arrComputers = Array( IPAdr )
Dim arrComputers, strComputer, objWMIService, objItem, colItems
For Each strComputer In arrComputers
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_ComputerSystem", "WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
For Each objItem In colItems
PCname = objItem.Name
Next
Next
End Function ' PCname( IPAdr )
#########################################################################
>>> wmi-pcreboot.vbs <<<
'*** v7.A *** www.dieseyer.de *******************************
'
' Datei: wmi-pcreboot.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Sendet mit WMI eine Reboot-Auforderung an einen PC.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim i, PCName
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
If i = 0 Then PCName = oArgs.item(i)
Next
' PCName = WScript.CreateObject("WScript.Network").ComputerName
' PCName = wshnet.ComputerName
' PCName = "53.73.179.56"
If PCName = "" Then PCName = InputBox( vbCRLF & vbCRLF & "Welcher PC soll neu gestartet werden?", WScript.ScriptName, PCName )
LogDatei( Now() & vbTab & PCName & " " & vbTab & " soll eine ReBoot-Anforderung bekommen." )
' PCreboot( PCName )
remoteShutdown( PCName )
LogDatei( Now() & vbTab & PCName & " " & vbTab & " hat eine ReBoot-Anforderung erhalten." )
WSHShell.Popup PCName & vbCRLF & vbCRLF & "hat eine ReBoot-Anforderung erhalten." ,15 , "0036 :: " & WScript.ScriptName, 64 + 4096 + 0
'*******************************************************
Sub remoteShutdown(remotename) ' 5.3 - http://dieseyer.de
'*******************************************************
' http://groups.google.de/groups?hl=de&lr=&newwindow=1&frame=right&th=43c55ccb528dbbc3&seekm=ebO58v50DHA.2480%40TK2MSFTNGP10.phx.gbl#link5
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.3 - http://dieseyer.de
'*******************************************************
Sub PCreboot( strComputer ) ' 5.3 - http://dieseyer.de
'*******************************************************
Dim objWMIService, colOperatingSystems, ObjOperatingSystem
' On Error Resume Next ' wird immer ausgeführt
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate,(Shutdown)}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
ObjOperatingSystem.Reboot()
Next
On Error GoTo 0
End Sub ' PCreboot( strComputer ) 5.3 - http://dieseyer.de
'*******************************************************
Sub LogDatei( Txt ) ' Anfang
'*******************************************************
CreateObject("Scripting.FileSystemObject").OpenTextFile( WScript.ScriptName & ".log" , 8, true ).WriteLine( Txt )
End Sub ' LogDatei
#########################################################################
>>> wmi-ping.vbs <<<
'*** v9.3 *** www.dieseyer.de ******************************
'
' Datei: wmi-ping.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Gibt 'kurzfristig' zurück, ob ein PC erreichbar ist.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Tst, ZielPC
ZielPC = "129.0.0.1"
ZielPC = "127.0.0.1"
Tst = Timer
' If WMIpingOK( ZielPC ) = False Then
If not WMIpingOK( ZielPC ) Then
MsgBox ZielPC & vbCRLF & vbCRLF & "ist momentan nicht erreichbar!"& vbCRLF & vbCRLF & "Später noch einmal versuchen.", , Timer - Tst & " - " & WScript.ScriptName
WScript.Quit
End If
MsgBox ZielPC & vbCRLF & vbCRLF & "ist jetzt erreichbar!", , Timer - Tst & " - " & WScript.ScriptName
WScript.Quit
'*** v9.3 *** www.dieseyer.de ******************************
Function WMIpingOK( PCName )
'***********************************************************
' 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 )
#########################################################################
>>> wmi-regkeywrite.vbs <<<
'v6.7********************************************************
' File: wmi-regkeywrite.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt, KeyInh
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim PCName : PCName = WshNet.ComputerName ' PCName = "." : PCName = "ds-pc" : PCName = "192.168.123.11" : PCName = "mein-pc"
Dim KeyPath : KeyPath = "SOFTWARE\dieseyer.de\Enviroment"
Dim KeyKey : KeyKey = "NurSoWas"
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\default:StdRegProv")
Const HKCU = &H80000001
Const HKEY_USERS = &H80000003
Const HKLM = &H80000002
' Inhalt lesen
oReg.GetExpandedStringValue HKLM,KeyPath,KeyKey,KeyInh
Txt = KeyInh
' Inhalt schreiben
oReg.CreateKey HKLM,KeyPath
oReg.SetStringValue HKLM,KeyPath,KeyKey,"17-13"
' Inhalt lesen
oReg.GetExpandedStringValue HKLM,KeyPath,KeyKey,KeyInh
MsgBox "vorher:" & vbTab & Txt & vbCRLF & "nacher:" & vbTab & KeyInh, , PCName
WScript.Quit
#########################################################################
>>> wmi-servicestarten.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: servicestarten.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Function ServiceStatus( Dienst )
' Function ServiceStoppen( Dienst )
' Function ServiceStarten( Dienst )
' Function ServiceAuto( Dienst ) mit starten
' Function ServiceManual( Dienst ) mit stoppen
' Function ServiceDeaktivieren( Dienst ) mit stoppen
' ( Sub LogEintrag( LogTxt ) )
'
' Eine Anforderung zum Stoppen oder Starten eines Dienstes
' kann bis zur Umsetzung etwas dauern - deshalb den Status
' nach einer kleine Pause (.Sleep 15*1000) erneut testen,
' oder wie in:
'
' Function ServiceNeuStarten( Dienst )
' nach dem Stoppen/Starten eines Dienstes wir in einer
' Do..Loop-Schleife gewartet, bis die Anforderung ("Pending")
' abgeschlossen ist.
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WshShell : Set WSHShell = CreateObject("Wscript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim LogDatei : LogDatei = WScript.ScriptFullName & ".log"
Dim Titel : Titel = WScript.ScriptName
'' WSHShell.Popup "= = = S T A R T = = =", 2, "036 :: " & WScript.ScriptName
LogEintrag ""
LogEintrag " "
LogEintrag "039 :: === S T A R T: " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
LogEintrag "040 :: LogDatei: " & LogDatei
LogEintrag "041 :: PCname: " & WSHNet.ComputerName
LogEintrag "042 :: Angemeldeter User: " & WSHNet.UserName
Dim ZwTxt
Dim DienstTxt
DienstTxt = "Gibts nich"
DienstTxt = "Automatische Updates"
DienstTxt = "Konfigurationsfreie drahtlose Verbindung"
Const VielLog = "-JA" ' "JA" für umfangreiechere LOGs (nicht nur die Ergebnisse)
ServiceNeuStarten DienstTxt
MsgBox "ServiceNeuStarten (" & DienstTxt & ") beendet.", , "056 :: " & Titel
ZwTxt = ServiceStatus( DienstTxt )
WSHShell.Popup ZwTxt, 10, "060 :: " & Titel, 4096
' LogEintrag "061 :: " & ZwTxt
ZwTxt = ServiceDeaktivieren( DienstTxt )
WSHShell.Popup ZwTxt, 10, "064 :: " & Titel, 4096
' LogEintrag "065 :: " & ZwTxt
ZwTxt = ServiceStarten( DienstTxt )
WSHShell.Popup ZwTxt, 10, "068 :: " & Titel, 4096
' LogEintrag "069 :: " & ZwTxt
ZwTxt = ServiceAuto( DienstTxt )
WSHShell.Popup ZwTxt, 10, "072 :: " & Titel, 4096
' LogEintrag "073 :: " & ZwTxt
ZwTxt = ServiceStatus( DienstTxt )
WSHShell.Popup ZwTxt, 10, "076 :: " & Titel, 4096
' LogEintrag "077 :: " & ZwTxt
WSHShell.Popup "= = = E N D E = = =", 2, "080 :: " & WScript.ScriptName
LogEintrag "081 :: === E N D E: " & WScript.ScriptFullName & " ( " & fso.GetFile( WScript.ScriptFullName ).DateLastModified & " )"
Wscript.Quit
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceNeuStarten( Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
If VielStat = "JA" Then LogEintrag " "
If VielStat = "JA" Then LogEintrag "096 :: >>> Dienst: """ & Dienst & """ "
ServiceStatus( Dienst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If VielStat = "JA" Then LogEintrag "101 :: >>> Dienst: """ & Dienst & """ "
ServiceStoppen( Dienst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
If VielStat = "JA" Then LogEintrag "107 :: >>> Dienst: """ & Dienst & """ "
Tst = ServiceStatus( Dienst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If InStr( UCase( Tst ), " PENDING)" ) = 0 Then Exit Do
WScript.Sleep 100
Loop
If VielStat = "JA" Then LogEintrag "114 :: >>> Dienst: """ & Dienst & """ "
ServiceStarten( Dienst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do
If VielStat = "JA" Then LogEintrag "120 :: >>> Dienst: """ & Dienst & """ "
Tst = ServiceStatus( Dienst )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If InStr( UCase( Tst ), " PENDING)" ) = 0 Then Exit Do
WScript.Sleep 100
Loop
If VielStat = "JA" Then LogEintrag "127 :: >>> Dienst: """ & Dienst & """ "
End Function ' ServiceNeuStarten( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceStatus( Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge '
ServiceStatus = ""
If VielStat = "JA" Then LogEintrag " "
If VielStat = "JA" Then LogEintrag "--- Start: Function ServiceStatus( """ & Dienst & """ )"
If VielStat = "JA" Then LogEintrag "143 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . ."
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "152 :: " & Dienst & " hat schon den richtigen Namen."
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "154 :: " & Dienst & " heisst 'richtig': " & objService.Name
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServiceStatus = """" & Dienst & """ existiert nicht."
LogEintrag "159 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden."
If VielStat = "JA" Then LogEintrag "160 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" "
Exit Function
End If
If VielStat = "JA" Then LogEintrag "163 :: ==> """ & Dienst & """ soll getestet werden. . ."
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStatus = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
LogEintrag "175 :: " & ServiceStatus
If VielStat = "JA" Then LogEintrag "--- Ende: Function ServiceStatus( Dienst )"
End Function ' ServiceStatus( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceStarten( Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService, colServices
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
ServiceStarten = ""
If VielStat = "JA" Then LogEintrag " "
If VielStat = "JA" Then LogEintrag "--- Start: Function ServiceStarten( """ & Dienst & """ )"
If VielStat = "JA" Then LogEintrag "193 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . ."
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "202 :: " & Dienst & " hat schon den richtigen Namen."
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "204 :: " & Dienst & " heisst 'richtig': " & objService.Name
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServiceStarten = """" & Dienst & """ existiert nicht."
LogEintrag "209 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden."
If VielStat = "JA" Then LogEintrag "210 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" "
Exit Function
End If
If VielStat = "JA" Then LogEintrag "213 :: ==> """ & Dienst & """ soll gestartet werden. . ."
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStarten = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "225 :: " & ServiceStarten
' "richtigen" (Dienst-) Namen starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service where Name='" & Dienst & "'")
For Each objService in colServices
ServiceStarten = objService.StartService()
Next
Set objWMIService = nothing
Set colServices = Nothing
Tst = ServiceStarten ' Wenn ServiceStarten Text enthält, gibt es bei "If Tst = 14 Then" einen Fehler
If Tst = 0 Then ServiceStarten = ServiceStarten & ": Dienst erfolgreich gestartet."
If Tst = 10 Then ServiceStarten = ServiceStarten & ": Dienst war bereits gestartet."
If Tst = 14 Then ServiceStarten = ServiceStarten & ": Deaktivierter Dienst wurde nicht gestartet."
If VielStat = "JA" Then LogEintrag "241 :: " & ServiceStarten
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStarten = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
LogEintrag "253 :: " & ServiceStarten
If VielStat = "JA" Then LogEintrag "--- Ende: Function ServiceStarten( Dienst )"
End Function ' ServiceStarten( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceDeaktivieren( Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
ServiceDeaktivieren = ""
If VielStat = "JA" Then LogEintrag " "
If VielStat = "JA" Then LogEintrag "--- Start: Function ServiceDeaktivieren( """ & Dienst & """ )"
If VielStat = "JA" Then LogEintrag "271 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . ."
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "280 :: " & Dienst & " hat schon den richtigen Namen."
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "282 :: " & Dienst & " heisst 'richtig': " & objService.Name
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServiceDeaktivieren = """" & Dienst & """ existiert nicht."
LogEintrag "287 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden."
If VielStat = "JA" Then LogEintrag "288 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" "
Exit Function
End If
If VielStat = "JA" Then LogEintrag "291 :: ==> """ & Dienst & """ soll deaktiviert werden. . ."
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceDeaktivieren = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "303 :: " & ServiceDeaktivieren
' "richtigen" Dienst (-Namen) setzen auf stoppen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceDeaktivieren = objService.StopService
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "315 :: Reaktion auf """ & Dienst & """ stoppen: " & ServiceDeaktivieren
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceDeaktivieren = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "327 :: " & ServiceDeaktivieren
' "richtigen" Dienst (-Namen) setzen auf "Disabled"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceDeaktivieren = objService.Change( , , , , "Disabled" )
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "339 :: Reaktion auf """ & Dienst & """ deaktivieren: " & ServiceDeaktivieren
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceDeaktivieren = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
LogEintrag "351 :: " & ServiceDeaktivieren
If VielStat = "JA" Then LogEintrag "--- Ende: Function ServiceDeaktivieren( Dienst )"
End Function ' ServiceDeaktivieren( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceManual( Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
ServiceManual = ""
If VielStat = "JA" Then LogEintrag " "
If VielStat = "JA" Then LogEintrag "--- Start: Function ServiceManual( """ & Dienst & """ )"
If VielStat = "JA" Then LogEintrag "369 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . ."
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "378 :: " & Dienst & " hat schon den richtigen Namen."
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "380 :: " & Dienst & " heisst 'richtig': " & objService.Name
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServicManual = """" & Dienst & """ existiert nicht."
LogEintrag "385 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden."
If VielStat = "JA" Then LogEintrag "386 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" "
Exit Function
End If
If VielStat = "JA" Then LogEintrag "389 :: ==> """ & Dienst & """ soll auf 'manuell' gesetzt werden. . ."
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceManual = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "401 :: " & ServiceManual
' "richtigen" Dienst (-Namen) stoppen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceManual = objService.StopService
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "413 :: Reaktion auf """ & Dienst & """ stoppen: " & ServiceManual
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceManual = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "425 :: " & ServiceManual
' "richtigen" Dienst (-Namen) setzen auf "Manual"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceManual = objService.Change( , , , , "Manual" )
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "437 :: Reaktion auf """ & Dienst & """ auf 'manuell' setzen: " & ServiceManual
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceManual = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
LogEintrag "449 :: " & ServiceManual
If VielStat = "JA" Then LogEintrag "--- Ende: Function ServiceManual( Dienst )"
End Function ' ServiceManual( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceAuto( Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
ServiceAuto = ""
If VielStat = "JA" Then LogEintrag " "
If VielStat = "JA" Then LogEintrag "--- Start: Function ServiceAuto( """ & Dienst & """ )"
If VielStat = "JA" Then LogEintrag "467 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . ."
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "476 :: " & Dienst & " hat schon den richtigen Namen."
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "478 :: " & Dienst & " heisst 'richtig': " & objService.Name
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServiceAuto = """" & Dienst & """ existiert nicht."
LogEintrag "483 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden."
If VielStat = "JA" Then LogEintrag "484 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" "
Exit Function
End If
If VielStat = "JA" Then LogEintrag "487 :: ==> """ & Dienst & """ soll auf 'Auto' gesetzt werden. . ."
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceAuto = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "499 :: " & ServiceAuto
' "richtigen" Dienst (-Namen) setzen auf "Auto"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceAuto = objService.Change( , , , , "Automatic" )
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "511 :: Reaktion auf """ & Dienst & """ auf 'Auto' setzen: " & ServiceAuto
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceAuto = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "523 :: " & ServiceAuto
' "richtigen" Dienst (-Namen) starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceAuto = objService.StartService
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "535 :: Reaktion auf """ & Dienst & """ starten: " & ServiceAuto
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceAuto = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
LogEintrag "547 :: " & ServiceAuto
If VielStat = "JA" Then LogEintrag "--- Ende: Function ServiceAuto( Dienst )"
End Function ' ServiceAuto( Dienst )
'*** v8.3 *** www.dieseyer.de *******************************
Function ServiceStoppen( Dienst )
'************************************************************
' Dienst ist der im Dienstmanager angezeigte Dienstname
Dim objWMIService, colListOfServices, objService
Dim Tst, VielStat
On Error Resume Next : VielStat = VielLog : On Error Goto 0 ' Wenn "VielLog" nicht definiert ist, gibts wenige LOG-Einträge
ServiceStoppen = ""
If VielStat = "JA" Then LogEintrag " "
If VielStat = "JA" Then LogEintrag "--- Start: Function ServiceStoppen( """ & Dienst & """ )"
If VielStat = "JA" Then LogEintrag "565 :: von """ & Dienst & """ wird der 'richtige' Name ermittelt . . ."
' "richtigen" (Dienst-) Namen suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * From Win32_Service")
Tst = "-OK"
For Each objService in colListOfServices
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "574 :: " & Dienst & " hat schon den richtigen Namen."
If InStr( UCase( objService.Name) , UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then If VielStat = "JA" Then LogEintrag "576 :: " & Dienst & " heisst 'richtig': " & objService.Name
If InStr( UCase( objService.DisplayName), UCase( Dienst ) ) = 1 Then Dienst = objService.Name : Tst = "OK" : Exit For
Next
If not Tst = "OK" Then
ServiceStoppen = """" & Dienst & """ existiert nicht."
LogEintrag "581 :: """ & Dienst & """ existiert nicht - kann also nicht gestartet werden."
If VielStat = "JA" Then LogEintrag "582 :: Vorzeitiges Ende ""Function ServiceStarten( Dienst )"" "
Exit Function
End If
If VielStat = "JA" Then LogEintrag "585 :: ==> """ & Dienst & """ soll gestoppt werden. . ."
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStoppen = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "597 :: " & ServiceStoppen
' "richtigen" Dienst (-Namen) stoppen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStoppen = objService.StopService
Next
Set objWMIService = nothing
Set colListOfServices = nothing
If VielStat = "JA" Then LogEintrag "609 :: Reaktion auf """ & Dienst & """ stoppen: " & ServiceStoppen
' "richtigen" Dienst (-Namen) testen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
ServiceStoppen = " """ & objService.Name & """ steht auf: " & objService.StartMode & " (" & objService.State & ")": Exit For
Next
Set objWMIService = nothing
Set colListOfServices = nothing
LogEintrag "621 :: " & ServiceStoppen
If VielStat = "JA" Then LogEintrag "--- Ende: Function ServiceStoppen( Dienst )"
End Function ' ServiceStoppen( Dienst )
'*** 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 )
#########################################################################
>>> wmi-standarddrucker.vbs <<<
'*** v8.3 *** www.dieseyer.de *******************************
'
' Datei: wmi-standarddrucker.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
MsgBox AlleDrucker( "." )
MsgBox Standarddrucker( "." )
WScript.Quit
'*** v8.3 *** www.dieseyer.de *******************************
Function AlleDrucker( PC )
'************************************************************
Dim objWMIService, colInstalledPrinters, oPrn
AlleDrucker = ""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery ("Select * from Win32_Printer")
For Each oPrn in colInstalledPrinters
AlleDrucker = AlleDrucker & oPrn.Name
If Len( oPrn.Location ) > 1 Then AlleDrucker = AlleDrucker & " - " & oPrn.Location
If oPrn.Default = True Then AlleDrucker = AlleDrucker & " - Standarddrucker"
AlleDrucker = AlleDrucker & vbCRLF
Next
End Function ' AlleDrucker( PC )
'*** v8.3 *** www.dieseyer.de *******************************
Function Standarddrucker( PC )
'************************************************************
Dim objWMIService, colInstalledPrinters, oPrn
Standarddrucker = ""
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery ("Select * from Win32_Printer")
For Each oPrn in colInstalledPrinters
If oPrn.Default = True Then Standarddrucker = oPrn.Name ' & " - " & oPrn.Location
Next
End Function ' Standarddrucker( PC )
#########################################################################
>>> wmi-userislogon.vbs <<<
'*** v3.A*** www.dieseyer.de *******************************
'
' Datei: wmi-userislogon.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' gibt den gerade angemeldeten User zurück
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim PCName
PCName = "."
If PCName = "" Then
MsgBox "Servername oder IP-Adresse angeben!" & vbCRLF & vbCRLF & ". . . das ist das Ende" , , WScript.ScriptName
WScript.Quit
End If
MsgBox UserIsLogon ( PCName ), , WScript.ScriptName
MsgBox UserIsLogon ( "192.168.1.19" ), , WScript.ScriptName
WScript.Quit
'*** v3.A*** www.dieseyer.de *******************************
Function UserIsLogon ( PC )
'***********************************************************
Dim objWMIService, colItems, objItem
On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\" & PC & "\root\cimv2")
if not err.Number = 0 then
If err.Number = -2147217405 Then err.Description = "Access Denied"
UserIsLogon = PC & " ==>" & err.Description & " - Fehlernr. " & err.Number
WScript.Quit
End If
Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
For Each objItem in colItems
if not objItem.UserName = "" then
UserIsLogon = PC & " ==> " & objItem.UserName & vbTab & " ist angemeldet"
Else
UserIsLogon = PC & " ==> kein angemeldeter User"
End If
Next
On Error GoTo 0
End Function ' UserIsLogon ( PC )
#########################################################################
>>> wmi-vbsalsservice.vbs <<<
'v5.5***********************************************************
' File: wmi-VBSalsService.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Das Skript zeigt, wie sich ein VBScript als Dienst eintragen
' lässt, der vor der Benutzeranmeldung gestartet wird.
'
' Im Dienstnamen darf kein Leerzeichen (Space) enthalten sein!
'
' Richtige Dienste bzw. Services melden an den Dienstmanager
' "etwas" zurück. Einfache Skripte können dies nicht. Aus diesem
' Grund wird ein Skript gestartet, das ein anderes startet. Der
' Dienstmanager beendet nämlich Dienste, die keine Meldungen
' an ihn zurück geben.
' Dieses Startskript "C:\test\VBSstart.vbs" besteht aus nur einer
' Zeile:
' CreateObject("Wscript.Shell").Run "C:\test\richtiges.vbs"
'
' Am Ende des Skripts "wmi-VBSalsService.vbs" wird der Dienst
' auch gleich wieder entfernt.
'***************************************************************
' Skript erstellen: http://msdn.microsoft.com/library/en-us/wmisdk/wmi/create_method_in_class_win32_baseservice.asp
Option Explicit
Call ServiceErstellen
WScript.Sleep 2*1000
Call ServiceStarten
WScript.Sleep 2*1000
Call ServiceEntfernen
MsgBox WScript.ScriptName & " - Skriptende.", , "0038 :: " & WScript.ScriptName
WScript.Quit
'*********************************************************
Sub ServiceErstellen
'*********************************************************
Const Dienst = "A1Service"
Const Progr = "wscript.exe C:\test\VBSstart.vbs"
Const INTERACTIVE_YES = True
Const INTERACTIVE_NOT = False
Dim objWMIService, colStoppedServices, colServices, objService
Dim Txt
' Test, ob Dienst schon installiert ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colStoppedServices = objWMIService.ExecQuery ("Select * From Win32_Service" )
For Each objService in colStoppedServices
If InStr( objService.DisplayName, Dienst ) > 0 Then Txt = """" & objService.DisplayName & """ (" & objService.State & ")"
Next
If Len( Txt ) > 5 Then MsgBox Txt & " existiert bereits", , "0064 :: " & WScript.ScriptName : Exit Sub
' Dienst installieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set objService = objWMIService.Get("Win32_BaseService")
Txt = objService.Create( Dienst, Dienst, Progr, , , "Automatic", INTERACTIVE_NOT )
MsgBox "Der Dienst """ & Dienst & """ wurde erstellt: RC=" & Txt, , "0072 :: " & WScript.ScriptName
Txt = ""
' Test, ob Dienst jetzt installiert ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colStoppedServices = objWMIService.ExecQuery ("Select * From Win32_Service" )
For Each objService in colStoppedServices
If InStr( objService.DisplayName, Dienst ) > 0 Then Txt = """" & objService.DisplayName & """ (" & objService.State & ")"
Next
MsgBox Txt & " ist jetzt installiert.", , "0083 :: " & WScript.ScriptName
End Sub ' ServiceErstellen
'*********************************************************
Sub ServiceEntfernen
'*********************************************************
Const Dienst = "A1Service"
Dim colListOfServices
Dim colStoppedServices, objWMIService, objService
Dim Txt
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("SELECT * FROM Win32_Service WHERE Name = '" & Dienst & "'")
For Each objService in colListOfServices
objService.StopService()
objService.Delete()
Next
Txt = ""
' Test, ob Dienst jetzt installiert ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colStoppedServices = objWMIService.ExecQuery ("Select * From Win32_Service" )
For Each objService in colStoppedServices
If InStr( objService.DisplayName, Dienst ) > 0 Then Txt = """" & objService.DisplayName & """ (" & objService.State & ")"
Next
If Len( Txt ) > 5 Then
MsgBox Txt & " lässt sich nicht entfernen.", , "0113 :: " & WScript.ScriptName
Else
MsgBox "Der Dienst """ & Dienst & """ ist jetzt entfernt.", , "0115 :: " & WScript.ScriptName
End If
End Sub ' ServiceEntfernen
'*********************************************************
Sub ServiceStarten
'*********************************************************
Const Dienst = "A1Service"
Dim objWMIService, colStoppedServices, colServices, objService
Dim Txt
' Test, ob Dienst schon installiert ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colStoppedServices = objWMIService.ExecQuery ("Select * From Win32_Service" )
For Each objService in colStoppedServices
If InStr( objService.DisplayName, Dienst ) > 0 Then Txt = """" & objService.DisplayName & """ (" & objService.State & ")"
Next
If Len( Txt ) > 5 Then MsgBox Txt & " existiert.", , "0138 :: " & WScript.ScriptName
' Dienst starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colServices = objWMIService.ExecQuery ("Select * from Win32_Service where Name='Alerter'")
For Each objService in colServices
Txt = objService.StartService()
If Txt <> 0 Then
MsgBox "Fehler beim starten des Dienstes """ & Dienst & """" & vbCRLF & "Error code = " & Txt, , "0148 :: " & WScript.ScriptName
Else
MsgBox "Dienst """ & Dienst & """ ist gestartet", , "0150 :: " & WScript.ScriptName
End If
Next
Txt = ""
' Test, ob Dienst jetzt installiert ist
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colStoppedServices = objWMIService.ExecQuery ("Select * From Win32_Service" )
For Each objService in colStoppedServices
If InStr( objService.DisplayName, Dienst ) > 0 Then Txt = """" & objService.DisplayName & """ (" & objService.State & ")"
Next
MsgBox Txt & " ist vorhanden.", , "0164 :: " & WScript.ScriptName
End Sub ' ServiceStarten
#########################################################################
>>> wmi-winver.vbs <<<
'v5.A********************************************************
' File: wmi-winver.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Einige Infos zum Betreibssystem.
'
' Im wesentlichen aus
' http://www.microsoft.com/downloads/details.aspx?FamilyID=b4cb2678-dafb-4e30-b2da-b8814fe2da5a&DisplayLang=en
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim Txt
Dim strComputer : strComputer = "."
Dim objWMIService : Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim colOperatingSystems : Set colOperatingSystems = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select * from Win32_OperatingSystem")
Dim objOperatingSystem
For Each objOperatingSystem in colOperatingSystems
Txt = Txt & objOperatingSystem.ServicePackMajorVersion & "." & objOperatingSystem.ServicePackMinorVersion
Next
' Txt = Txt & vbCRLF
Txt = ""
Dim colOSes : Set colOSes = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Dim objOS
For Each objOS in colOSes
Txt = Txt & vbCRLF & "Computer Name: " & objOS.CSName
Txt = Txt & vbCRLF & "Caption: " & objOS.Caption 'Name
Txt = Txt & vbCRLF & "Version: " & objOS.Version 'Version & build
Txt = Txt & vbCRLF & "Build Number: " & objOS.BuildNumber 'Build
Txt = Txt & vbCRLF & "Build Type: " & objOS.BuildType
Txt = Txt & vbCRLF & "OS Type: " & objOS.OSType
Txt = Txt & vbCRLF & "Other Type Description: " & objOS.OtherTypeDescription
Txt = Txt & vbCRLF & "Service Pack: " & objOS.ServicePackMajorVersion & "." & objOS.ServicePackMinorVersion
Next
MsgBox Txt, , WScript.ScriptName
#########################################################################
>>> wmi-winversp.vbs <<<
'*** v10.C *** www.dieseyer.de *****************************
'
' Datei: wmi-winversp.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Programm ermittelt WindowsNT-Version und Sp-Version
'
' Microsoft: The Portable Script Center - v3.0, Nov. 2004
' "List System Information"
'
'***********************************************************
Option Explicit
MsgBox ListSystemInformation( "." ), , "16 :: " & WScript.ScriptName
WScript.Quit
'*** v10.C *** www.dieseyer.de *****************************
Function ListSystemInformation( PC )
'***********************************************************
Dim objWMIService, colSettings, objOperatingSystem, objComputer, objProcessor, objBIOS
Dim Txt
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colSettings
Txt = Txt & vbCRLF & "OS Name: " & vbTab & vbTab & objOperatingSystem.Name
Txt = Txt & vbCRLF & "OSArchitecture: " & vbTab & vbTab & objOperatingSystem.OSArchitecture
Txt = Txt & vbCRLF & "Version: " & vbTab & vbTab & vbTab & objOperatingSystem.Version
Txt = Txt & vbCRLF & "Service Pack: " & vbTab & vbTab & objOperatingSystem.ServicePackMajorVersion & "." & objOperatingSystem.ServicePackMinorVersion
Txt = Txt & vbCRLF & "OS Manufacturer: " & vbTab & vbTab & objOperatingSystem.Manufacturer
Txt = Txt & vbCRLF & "Windows Directory: " & vbTab & objOperatingSystem.WindowsDirectory
Txt = Txt & vbCRLF & "Locale: " & vbTab & vbTab & vbTab & objOperatingSystem.Locale
Txt = Txt & vbCRLF & "Available Physical Memory: " & vbTab & objOperatingSystem.FreePhysicalMemory
Txt = Txt & vbCRLF & "Total Virtual Memory: " & vbTab & objOperatingSystem.TotalVirtualMemorySize
Txt = Txt & vbCRLF & "Available Virtual Memory: " & vbTab & objOperatingSystem.FreeVirtualMemory
Txt = Txt & vbCRLF & "Size stored in paging files: " & vbTab & objOperatingSystem.SizeStoredInPagingFiles
Next
Set colSettings = objWMIService.ExecQuery ("Select * from Win32_ComputerSystem")
For Each objComputer in colSettings
Txt = Txt & vbCRLF & "System Name: " & vbTab & vbTab & objComputer.Name
Txt = Txt & vbCRLF & "System Manufacturer: " & vbTab & objComputer.Manufacturer
Txt = Txt & vbCRLF & "System Model: " & vbTab & vbTab & objComputer.Model
Txt = Txt & vbCRLF & "Time Zone: " & vbTab & vbTab & objComputer.CurrentTimeZone
Txt = Txt & vbCRLF & "Total Physical Memory: " & vbTab & objComputer.TotalPhysicalMemory
Next
Set colSettings = objWMIService.ExecQuery ("Select * from Win32_Processor")
For Each objProcessor in colSettings
Txt = Txt & vbCRLF & "System Type: " & vbTab & vbTab & objProcessor.Architecture
Txt = Txt & vbCRLF & "Processor: " & vbTab & vbTab & objProcessor.Description
Next
Set colSettings = objWMIService.ExecQuery ("Select * from Win32_BIOS")
For Each objBIOS in colSettings
Txt = Txt & vbCRLF & "BIOS Version: " & vbTab & vbTab & objBIOS.Version
Next
ListSystemInformation = Txt
End Function ' ListSystemInformation( PC )
#########################################################################
>>> wmi-x64.vbs <<<
'*** v10.C *** www.dieseyer.de *****************************
'
' Datei: wmi-x64.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Programm ermittelt, ob die Betriebssystemarchitektur
' 64-Bit
' ist - also: bei 64-Bit = True
'
'***********************************************************
Option Explicit
MsgBox "Ist das Betriebsystem 64-Bit?" & vbCRLF & vbCRLF & vbTab & ist64bit( "." ), , "15 :: " & WScript.ScriptName
WScript.Quit
'*** v10.C *** www.dieseyer.de *****************************
Function ist64bit( PC )
'***********************************************************
Dim objWMIService, colSettings, objOperatingSystem
Dim Tst
On Error resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colSettings
Tst = objOperatingSystem.OSArchitecture
If InStr( Tst, "64" ) = 1 Then ist64bit = True : Exit Function
Next
' If InStr( Tst, 64 ) = 1 Then ist64bit = True
ist64bit = False
End Function ' ist64bit( PC )
#########################################################################
>>> wsh-info.vbs <<<
'v2.A*****************************************************
' File: wsh-info.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' zeigt Informationen zum WSH
'*********************************************************
TextX = vbCRLF
TextX = TextX & "WScript.ScriptName: " & vbTab & WScript.ScriptName & vbCRLF
TextX = TextX & "WScript.ScriptFullName: " & vbTab & WScript.ScriptFullName & vbCRLF
TextX = TextX & "WScript Path: " & vbTab & Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\") -1) & vbCRLF
set fso = CreateObject("Scripting.FileSystemObject")
TextX = TextX & "WScript Path: " & vbTab & fso.GetParentFolderName( WScript.ScriptFullName ) & vbCRLF
TextX = TextX & "WScript Path: " & vbTab & fso.GetFolder(".") & vbCRLF
TextX = TextX & "WScript.Applikation: " & vbTab & WScript.Application & vbCRLF
TextX = TextX & "WScript.Name: " & vbTab & WScript.Name & vbCRLF
TextX = TextX & "WScript.Version: " & vbTab & WScript.Version & vbCRLF
TextX = TextX & "WScript.FullName: " & vbTab & WScript.FullName & vbCRLF
TextX = TextX & "WScript.Path: " & vbTab & WScript.Path & vbCRLF
TextX = TextX & "ScriptEngine: " & vbTab & ScriptEngine & vbCRLF
TextX = TextX & "ScriptEngineMajorVersion: " & vbTab & ScriptEngineMajorVersion() & vbCRLF
TextX = TextX & "ScriptEngineMinorVersion: " & vbTab & ScriptEngineMinorVersion() & vbCRLF
TextX = TextX & "ScriptEngineBuildVersion: " & vbTab & ScriptEngineBuildVersion()
MsgBox TextX, , WScript.ScriptName
#########################################################################
>>> zeileandateianfangeinfügen.vbs <<<
'*** v9.6 *** www.dieseyer.de *******************************
'
' Datei: ZeileAnDateianfangEinfügen.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de / www.wintuc.de
'
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
ErsteZeileDazu WScript.ScriptFullName & ".log", Timer() & " --- " & Now() & " __ " & WScript.ScriptName
'*** v9.6 *** www.dieseyer.de *******************************
Sub ErsteZeileDazu( Datei, Txt )
'************************************************************
Dim objFSO : Set objFSO=CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists( Datei) Then
' Alles lesen und an Txt 'anhängen'
Txt = Txt & vbCRLF & objFSO.OpenTextFile( Datei ).ReadAll
Else
Txt = Txt & vbCRLF
End If
WScript.Sleep 33 ' 33ms warten
' Alles schreiben
objFSO.CreateTextFile( Datei ).Write( Txt)
End Sub ' ErsteZeileDazu( Datei, Txt )
#########################################################################
>>> zeileindateitauschen.vbs <<<
'v2.7********************************************************
' File: ZeileInDateiTauschen.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' In den Zeilen dürfen keine Anführungszeichen " stehen!
'
' dateiliste.txt stellt eine Liste der zu prüfenden Dateien
' bereit. Beim Skriptaufruf wird nach der zu suchenden
' Zeichenkette gefragt. Diese wird bei der Abfrage, wie die
' Zeile zukünftig heissen soll angezeigt und kann geändert
' werden. (Am einfachsten: zu suchende Zeile in die Zwischen-
' ablage übernehmen und beim Such-String eigeben.)
' (Ich habe damit in meinen HTML-Dateien u.a. das Bild und
' das <meta name="DC.Date" ... > Tag geändert.)
'************************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso, fo, fi, FinList, Fin, Fout
Dim Ziel, Quelle, WSHShell, ZielVerz
Dim TextX, Text1, Text2, Text3, Txt(), i, i1
Dim aHTML, eHTML, ZeileAlt, ZeileNeu, iText, DateiListe
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
ZielVerz = "m:\dieseyer.test"
ZielVerz = fso.GetParentFolderName( WScript.ScriptFullName )
DateiListe = ZielVerz & "\dateiliste.txt"
If not fso.FileExists( DateiListe ) Then MsgBox DateiListe & " existiert nicht!", , WSCript.ScriptName
If not fso.FileExists( DateiListe ) Then WScript.Quit
'---------------------------------------------------------
' DateiListe zeilenweise lesen (für Anzeige)
'---------------------------------------------------------
iText = ""
Set FinList = FSO.OpenTextFile( DateiListe, 1 ) ' Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
If iText = "" Then iText = TextX
Text1 = Text1 & vbCRLF & " " & TextX
End If
Loop
FinList.Close
Set FinList = nothing
TextX = ""
TextX = TextX & "In folgenden Dateien werden Zeilen ausgetauscht:" & vbCRLF
TextX = TextX & Text1
i = MsgBox (TextX, 4 + 32 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text1 = Text1 & "Wie lautet die komplette Zeile (ZeileAlt), die komplett erstezt werden soll?"
ZeileAlt = InputBox ( Text1 , WSCript.ScriptName , ZeileAlt)
If ZeileAlt = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
Text1 = ""
Text1 = Text1 & "Folgende Zeile (ZeileAlt) soll in den soeben gezeigten Dateien ausgetauscht werden."
Text1 = Text1 & "Ändern Sie jetzt diese Zeichenkette, um festzulegen, wie die Zeile in Zukunft (ZeileNeu) aussehen soll."
ZeileNeu = InputBox ( Text1 , WSCript.ScriptName , ZeileAlt)
If ZeileNeu = "" then
WSHShell.PopUp " . . . dann eben nicht!", , WScript.Scriptname
WSCript.Quit
End If
If ZeileAlt = ZeileNeu then
WSHShell.PopUp "Wenn ZeileNeu" & vbCRLF & " " & ZeileNeu & vbCRLF & "und ZeileAlt" & vbCRLF & " " & ZeileAlt & vbCRLF & "gleich sind, wird's nichts!", , WScript.Scriptname
WSCript.Quit
End If
TextX = "DAS IST DIE LETZTE WARNUNG!" & vbCRLF & vbCRLF & TextX
i = vbYes
' i = MsgBox (TextX, 4 + 48 +256, WScript.Scriptname)
If not i = vbYes then MsgBox " . . . dann eben nicht!", , WScript.Scriptname
If not i = vbYes then WScript.Quit
Text1 = ""
Text2 = ""
'---------------------------------------------------------
' DateiListe zeilenweise lesen & Zeile(n) tauschen
'---------------------------------------------------------
Set FinList = FSO.OpenTextFile( DateiListe, 1 ) ' DateiListe-Datei zum Lesen öffnen
Do While Not (FinList.atEndOfStream) ' wenn DateiListe-Datei nicht zu ende ist, weiter machen
TextX = FinList.Readline ' eine Zeile lesen
If not Left ( TextX, 1 ) = ";" AND not Left ( TextX, 1 ) = " " then
If not Text2 = "" then
Text1 = Text1 & vbCRLF & TextX & vbTab & " übersprungen"
Else
Text3 = ZeileInDateiTauschen (TextX, ZeileAlt, ZeileNeu) ' Function Aufruf
' if vbcancel = WSHShell.Popup (TextX & " . . . wurde bearbeitet.", 1, WScript.ScriptName, 1 + 64 ) Then Text2 = "übergehen"
Text1 = Text1 & vbCRLF & TextX & Text3
' Text1 = Text1 & vbCRLF & TextX & i
End If
End If
Loop
FinList.Close
Set FinList = nothing
MsgBox Text1, , WScript.ScriptName
WScript.Quit
'---------------------------------------------------------
Function ZeileInDateiTauschen (Datei, Suchen, Ersetzen)
'---------------------------------------------------------
Dim Fin, Fout, TextX, i
if not WScript.CreateObject("Scripting.FileSystemObject").FileExists(Datei) then
WScript.CreateObject("WScript.Shell").PopUp "Datei """ & Datei & """ nicht gefunden!", 1, WSCript.ScriptName, vbExclamation
ZeileInDateiTauschen = " " & vbTab & " nicht gefunden"
Exit Function
End If
WScript.CreateObject("Scripting.FileSystemObject").CopyFile Datei, Datei & ".tmp"
Set Fin = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Datei & ".tmp", 1 ) ' Datei zum Lesen öffnen
Set Fout = WScript.CreateObject("Scripting.FileSystemObject").OpenTextFile( Datei , 2, true) ' Datei neu anlegen & zum Schreiben öffnen
Do While Not (Fin.atEndOfStream) ' wenn Datei nicht zu Ende ist, weiter machen
TextX = Fin.Readline ' eine Zeile lesen
If InStr( TextX, Suchen ) > 0 Then
i = i + 1
Fout.WriteLine Ersetzen
Else
Fout.WriteLine TextX
End If
Loop
Fin.Close
Set Fin = Nothing ' Datei schließen
Fout.Close
Set Fout = Nothing ' Datei schließen
If i > 0 Then
' WScript.CreateObject("WScript.Shell").PopUp "Austausch in Datei """ & Datei & """ abgeschlossen " , 1, WSCript.ScriptName, vbExclamation
ZeileInDateiTauschen = " " & vbTab & i & " Zeile(n) getauscht."
Else
' WScript.CreateObject("WScript.Shell").PopUp "Die angegebene Zeile ==|" & Suchen & "|== konnte nicht in der Datei """ & Datei & """ gefunden werden." , 5, WSCript.ScriptName, vbExclamation
ZeileInDateiTauschen = " " & vbTab & " Zeile nicht gefunden."
End If
' WSCript.Sleep 2
'_____________________________________________
' folgende Zeile löscht die Sicherheitskopien
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile Datei & ".tmp", True
End Function ' ZeileInDateiTauschen
#########################################################################
>>> zeilennr-anpassen.vbs <<<
'v7.3***********************************************************
' File: zeilennr-anpassen.vbs
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'***************************************************************
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 oArgs : Set oArgs = Wscript.Arguments
Dim i, Txt
Dim DateiName, DateiSich
'hole alle Argumente
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
If i = 0 Then DateiName = oArgs.item(i)
If i = 1 Then DateiSich = oArgs.item(i)
Next
If DateiName = "" Then DateiName = WScript.ScriptFullName
Txt = fso.GetParentFolderName( DateiName ) & "\" & fso.GetBaseName( DateiName ) & "-." & fso.GetExtensionName( DateiName )
If DateiSich = "" Then DateiSich = Txt
Call ZeilenAnpassg( DateiName, DateiSich )
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If DateiName = WScript.ScriptFullName Then MsgBox "Das ist das Ende . . . ", , "333 :: " & WScript.ScriptName
WScript.Quit
'***************************************************************
Sub ZeilenAnpassg( Datei, Sicherg ) ' v7.3 - http://dieseyer.de
'***************************************************************
If Datei = WScript.ScriptFullName Then MsgBox Datei & vbCRLF & Sicherg, , "333 :: " & WScript.ScriptName
Dim DateiTypen : DateiTypen = ".hta.htm.html.vbs.cmd.bat.wsf"
' Von der 'Datei' wird eine Sicherung erstellt, wenn die Sicherungsdatei
' nicht existiert (wird für sendenan-sicherung.vbs benötigt)
'
' In allen Zeilen der 'Datei' wird nach ' :: ' (das sind 4 Zeichen)
' gesucht. Ist die Suche erfolgreich, werden zwei Fälle unterschieden -
' abhängig von den Zeichen _DAVOR_ :
'
' 1. Die Zeichen _DAVOR_ enthalten ein Anführungszeichen,
' gefolgt von einer max. 4stelligen Zahl (anschließend ' :: ')
' z.B.: MsgBox "123 :: Meldung"
' WScript.Echo "9 :: CScript.exe oder WScript.exe?"
' FileOut.WriteLine "9876 :: für LogDateien"
' Dies ist die VBS-Unterstützung (in .VBS / .HTA / .HTML)
'
' 2. Die Zeichen _DAVOR_ enthalten ein kleines 'o' (von 'Echo'),
' gefolgt von einem Leerschritt, gefolgt von einer max.
' 4stelligen Zahl (anschließend ' :: ')
' z.B.: Echo 123 :: Meldung
' Echo 6 :: Meldung um %date% %time% >> LogDatei.txt
' Dies ist die Befehlszeilen-Unterstützung (in .BAT / .CMD)
' Ist eine der beiden Bedingungen erfüllt, wird
' zu 1. die Zeichenkette zwischen Anführungszeichen und ' :: '
' zu 2. die Zeichenkette zwischen 'o ' und ' :: '
' durch die aktuelle Zeilennummer ersetzt - 4stellig mit führenden Nullen.
' Zum Testen das Skript ohne Parameter starten: Im Skript werden
' entsprechend den Bedingungen in den Beispielzeilen die korregierte Zeilem-
' nummer eingetragen und das Ergebnis mit Notepad angezeigt.
' Beim zweiten Aufruf dieses Skripts, werden auch die (MsgBox-) Meldungen
' die richtige Zeilennummer anzeigen.
' Hinweis: Die (Quell-) Datei wird _IMMER_ neu geschrieben!
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Dim Pos, Txt, Tst, i, n, PC, DateiName, Z
Dim FileOut, FileIn
If not fso.FileExists( Sicherg ) Then fso.CopyFile Datei, Sicherg, True
' Dateitypen prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = fso.GetExtensionName( Datei )
Tst = UCase( "." & Tst )
DateiTypen = UCase( DateiTypen )
If InStr( DateiTypen , Tst ) = 0 Then
' MsgBox "Dateien mit der Erweiterung" & vbCRLF & vbTab & Tst & vbCRLF & " werden nicht von ""Sub ZeilenAnpassg( Datei, Sicherg )"" unterstützt.", , "0489 :: " & WScript.ScriptName
Exit Sub
End If
' 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
ReDim Preserve Zeile(i)
Zeile(i) = FileIn.Readline
i = i + 1
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
If InStrRev( Zeile(i), " :: " ) > 4 Then
' Zahl auf vier Stellen mit führender 0 erweitern
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
n = i + 1
If Len( n ) = 1 Then n = "0" & n ' 2stellig
If Len( n ) = 2 Then n = "0" & n ' 3stellig
If Len( n ) = 3 Then n = "0" & n ' 4stellig
' If Len( n ) = 4 Then n = "0" & n ' 5stellig
' das erste Vorkommen von " :: " suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Pos = InStr( Zeile(i), " :: " )
If Pos > 7 Then ' weil sonst "Mid( Zeile(i), Pos - 6, 1 )" nicht geht
' das Anführungszeichen vor dem " :: " suchen und (neue) Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Mid( Zeile(i), Pos - 2, 1 ) = Chr(34) Then Zeile(i) = Mid( Zeile(i), 1, Pos - 2 ) & n & " :: " & Mid( Zeile(i), Pos + 3 )
If Mid( Zeile(i), Pos - 3, 1 ) = Chr(34) Then Zeile(i) = Mid( Zeile(i), 1, Pos - 3 ) & n & " :: " & Mid( Zeile(i), Pos + 3 )
If Mid( Zeile(i), Pos - 4, 1 ) = Chr(34) Then Zeile(i) = Mid( Zeile(i), 1, Pos - 4 ) & n & " :: " & Mid( Zeile(i), Pos + 3 )
If Mid( Zeile(i), Pos - 5, 1 ) = Chr(34) Then Zeile(i) = Mid( Zeile(i), 1, Pos - 5 ) & n & " :: " & Mid( Zeile(i), Pos + 3 )
' If Mid( Zeile(i), Pos - 6, 1 ) = Chr(34) Then Zeile(i) = Mid( Zeile(i), 1, Pos - 6 ) & n & " :: " & Mid( Zeile(i), Pos + 4 )
' unnötige Leerzeichen entfernen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Zeile(i) = Replace( Zeile(i), " :: ", " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
End If
Tst = InStr( LCase( Zeile(i) ), ".echo """ ) ' wenn DAS in der Zeile vor 'Pos' steht, darf der nächste Abschnitt nicht ausgeführt werden
If Tst = 0 Then Tst = 55555
If Pos > 5 AND Tst > Pos Then
' "o " (von 'echo 123 :: ' ) vor dem " :: " suchen und (neue) Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Mid( Zeile(i), Pos - 2, 2 ) = "o " Then Zeile(i) = Mid( Zeile(i), 1, Pos - 1 ) & n & " :: " & Mid( Zeile(i), Pos + 4 )
If Mid( Zeile(i), Pos - 3, 2 ) = "o " Then Zeile(i) = Mid( Zeile(i), 1, Pos - 2 ) & n & " :: " & Mid( Zeile(i), Pos + 4 )
If Mid( Zeile(i), Pos - 4, 2 ) = "o " Then Zeile(i) = Mid( Zeile(i), 1, Pos - 3 ) & n & " :: " & Mid( Zeile(i), Pos + 4 )
If Mid( Zeile(i), Pos - 5, 2 ) = "o " Then Zeile(i) = Mid( Zeile(i), 1, Pos - 4 ) & n & " :: " & Mid( Zeile(i), Pos + 4 )
If Mid( Zeile(i), Pos - 6, 2 ) = "o " Then Zeile(i) = Mid( Zeile(i), 1, Pos - 5 ) & n & " :: " & Mid( Zeile(i), Pos + 4 )
' If Mid( Zeile(i), Pos - 7, 2 ) = "o " Then Zeile(i) = Mid( Zeile(i), 1, Pos - 6 ) & n & " :: " & Mid( Zeile(i), Pos + 5 )
' unnötige Leerzeichen entfernen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Zeile(i) = Replace( Zeile(i), " :: ", " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
End If
End If
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Datei = fso.GetParentFolderName( Datei ) & "\" & fso.GetBaseName( Datei ) & "--." & fso.GetExtensionName( Datei )
' MsgBox Datei : WScript.Quit
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Datei = WScript.ScriptFullName Then WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepad) beendet ist
End Sub ' ZeilenAnpassg( Datei, Sicherg ) ' v7.3 - http://dieseyer.de
#########################################################################
>>> zeilennr-msgbox.vbs <<<
'v5.4***********************************************************
' File: zeilennr-msgbox.vbs
' Autor: dieseyer@gmx.de
' http://dieseyer.de
'
'
'
'***************************************************************
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 WSHNet : Set WSHNet = WScript.CreateObject("WScript.Network")
Dim WshSysEnv : Set WshSysEnv = WSHShell.Environment("SYSTEM")
Dim oArgs : Set oArgs = Wscript.Arguments
Dim Pfad : Pfad = fso.GetParentFolderName( WScript.ScriptFullName )
Dim Pos, Txt, Tst, i, n, PC, DateiName
Dim FileOut, FileIn
'hole alle Argumente
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
If i = 0 Then DateiName = oArgs.item(i)
Next
Call ZeilenNrMsgBox( DateiName )
' MsgBox "Das ist das Ende . . . ", , WScript.ScriptName
'***************************************************************
Sub ZeilenNrMsgBox( Datei )
'***************************************************************
' alle Zeilen lesen und an Array übergeben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = fso.GetParentFolderName( Datei ) & "\" & fso.GetBaseName( Datei ) & "-." & fso.GetExtensionName( Datei )
If not fso.FileExists( Txt ) Then fso.CopyFile Datei, Txt, True
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
i = i + 1
Loop
If i < 1 Then
ReDim Preserve Zeile(i)
Zeile(i) = "Leerdatei"
End If
FileIn.Close
Set FileIn = nothing
' Array bearbeiten; hier: Zeilennummer einfügen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for i = LBound( Zeile ) to UBound( Zeile )
If InStrRev( Zeile(i), " :: " ) > 4 Then
' Zeilennummer auf vier Stellen mit führender 0 erweitern
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
n = i + 1
If Len( n ) = 1 Then n = "0" & n
If Len( n ) = 2 Then n = "0" & n
If Len( n ) = 3 Then n = "0" & n
Pos = InStrRev( Zeile(i), " :: " )
' If i < 73 AND i > 60 Then InputBox Zeile(i), "76 : " & Pos, Zeile(i)
' MsgBox Txt, 4096, "67 : " & Anfang - " & WScript.ScriptName
' das Anführungszeichen vor dem " :: " suchen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Mid( Zeile(i), Pos - 5, 1 ) = """" Then
' if i < 130 Then MsgBox "1>" & Left( Zeile(i), Pos - 4 ) & "<1" & vbCRLF & "2>" & Mid( Zeile(i), Pos + 3 ) & "<2" & "<==" , 4096, n & " : 74 : "
Zeile(i) = Left( Zeile(i), Pos - 5 ) & n & " :: " & Mid( Zeile(i), Pos + 3 )
End If
If Mid( Zeile(i), Pos - 4, 1 ) = """" Then
' if i < 130 Then MsgBox "1>" & Left( Zeile(i), Pos - 4 ) & "<1" & vbCRLF & "2>" & Mid( Zeile(i), Pos + 3 ) & "<2" & "<==" , 4096, n & " : 74 : "
Zeile(i) = Left( Zeile(i), Pos - 4 ) & n & " :: " & Mid( Zeile(i), Pos + 3 )
End If
If Mid( Zeile(i), Pos - 3, 2 ) = "o " Then Zeile(i) = Left( Zeile(i), Pos - 3 ) & " " & n & " :: " & Mid( Zeile(i), Pos + 3)
If Mid( Zeile(i), Pos - 4, 2 ) = "o " Then Zeile(i) = Left( Zeile(i), Pos - 4 ) & " " & n & " :: " & Mid( Zeile(i), Pos + 3 )
If Mid( Zeile(i), Pos - 5, 2 ) = "o " Then Zeile(i) = Left( Zeile(i), Pos - 5 ) & " " & n & " :: " & Mid( Zeile(i), Pos + 3 )
If Mid( Zeile(i), Pos - 6, 2 ) = "o " Then Zeile(i) = Left( Zeile(i), Pos - 6 ) & " " & n & " :: " & Mid( Zeile(i), Pos + 3 )
If Mid( Zeile(i), Pos - 3, 1 ) = """" Then
' If i < 73 AND i > 60 Then MsgBox Zeile(i), , "76 : "
' if i < 130 Then MsgBox "1>" & Left( Zeile(i), Pos - 3 ) & "<1" & vbCRLF & "2>" & Mid( Zeile(i), Pos + 3 ) & "<2" & "<==" , 4096, n & " : 86 : "
Zeile(i) = Left( Zeile(i), Pos - 3 ) & n & " :: " & Mid( Zeile(i), Pos + 3)
End If
Zeile(i) = Replace( Zeile(i), " :: ", " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
Zeile(i) = Replace( Zeile(i), " :: " , " :: " )
End If
next
' Array in (Ziel-) Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Datei = fso.GetParentFolderName( Datei ) & "\" & fso.GetBaseName( Datei ) & "--." & fso.GetExtensionName( Datei )
' MsgBox Datei : WScript.Quit
Set FileOut = FSO.OpenTextFile( Datei , 2, true) ' Datei zum Screiben öffnen; 2: immer neu anlegen
' FileOut.WriteLine( vbCRLF & now() & vbCRLF ) ' nur Für Testzwecke
for i = 0 to ubound( Zeile )
FileOut.WriteLine( Zeile(i) )
next
FileOut.Close
Set FileOuT = nothing
' (Ziel-) Datei anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WSHShell.run "notepad """ & Datei & """" , , True ' True: Skriptabarbeitung wartet bis Programm (notepad) beendet ist
End Sub ' ZeilenNrMsgBox( Datei )
#########################################################################
>>> zeilennummer.vbs <<<
'v7.8***************************************************
' File: zeilennummer.vbs
' Autor: W.Schmelz
' http://dieseyer.de
'
' Beliebige Datei auf dies Programm ziehen und los-
' lassen. Der Datei - Inhalt wird dann zeilenweise
' mit der Zeilen - Nummerierung angezeigt!
'*************************************************
'CopyRight W. Schmelz, 09.08.2007
Titel=" Dateizeilen nummerieren !"
'Objekte für das Programm bereit stellen:
Set Wss=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Arg=Wscript.Arguments
UV=VbCR&VbCR
'Aufgesetzte Datei ermitteln:
For i=0 to Arg.Count -1
Datei=Arg.Item(i)
Next
'Falls keine Datei aufgesetzt wurde:
If Datei="" then MsgBox UV&VbCR&_
" Bitte eine Datei aufsetzen, deren"&UV&_
" Zeilen nummeriert werden sollen ! "&_
UV&" Diese Datei wird nicht angetastet !!"&UV&_
VbCR,VbCritical,Titel:WScript.Quit ' Abbruch !!!
'Aufgesetzte Datei zeilenweise lesen:
Set File=Fso.OpenTextFile(Datei,1,true)
i=1
Do until File.AtEndOfStream
ReDim Preserve Zeile(i)
Zeile(i)=File.ReadLine
i=i+1
Loop
Ende=i-1
File.Close
Set File=Nothing
'Die Zeilen durchnummerieren:
i=1
Do until i=Ende+1
Zeile(i)=i&VbTab&Zeile(i) 'VbTab gibt bei i Längenausgleich, nicht " "!
i=i+1
Loop
'Datei für die nummerierten Zeilen festlegen:
Stamm=Fso.GetParentFolderName(Datei)
Datei=Fso.GetBaseName(Datei)&"-Nr.txt"
Datei=Stamm&"\"&Datei
'Datei für die nummerierten Zeilen schreiben:
Set File=Fso.OpenTextFile(Datei,2,true)
i=1
Do until i=Ende+1
File.WriteLine(Zeile(i))
i=i+1
Loop
File.Close
Set File=Nothing
'Die Datei mit den Zeilen-Nr. anzeigen und dann diese löschen?
Wss.Run "Notepad """&Datei&""" "
WScript.Sleep 1500
'Frage, ob die ausgegebene Datei gelöscht werden soll:
Ask=MsgBox(UV&UV&_
"Soll die Datei mit den Zeilen-Nr. gelöscht werden ? "&_
UV&"Sie befindet sich im Verzeichnis dieser Datei !"&UV&_
UV,VbYesNo+VbDefaultButton2+VbCritical,Titel)
If Ask="7" then WScript.Quit ' Bei "Nein" Abbruch !
'Sonst die Datei mit den Zeilen - Nr. löschen:
WScript.Sleep 1500
Fso.DeleteFile Datei
#########################################################################
>>> zeitgestaffelt.vbs <<<
'v5.B*****************************************************
' File: zeitgestaffelt.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Startet zeitgestafflet verschiedene Skripte.
'
'*********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell")
Dim StartZeit : StartZeit = now()
Dim Nach20 : Nach20 = 20
Dim Nach40 : Nach40 = 40
Dim Nach60 : Nach60 = 60
Dim Intervall : Intervall = "s" ' für Sekunden; n für Minuten
Dim LaufZeit
MsgBox "Es geht los!", , "0021 :: " & WScript.ScriptName
Do
LaufZeit = DateDiff( "s", StartZeit, now() )
' MsgBox "LaufZeit: " & LaufZeit, , "0026 :: " & WScript.ScriptName
If LaufZeit > 20 Then
If not Nach20 = 0 Then
Nach20 = 0
' WSHShell.Run( "20.vbs" )
MsgBox "20.vbs", , "0031 :: " & WScript.ScriptName
End If
End If
If LaufZeit > 40 Then
' If not Nach40 = 0 Then Nach40 = 0 : WSHShell.Run( "40.vbs" )
If not Nach40 = 0 Then Nach40 = 0 : MsgBox "40.vbs", , "0037 :: " & WScript.ScriptName
End If
' If LaufZeit > 60 AND not Nach60 = 0 Then Nach60 = 0 : WSHShell.Run( "60.vbs" )
If LaufZeit > 60 AND not Nach60 = 0 Then Nach60 = 0 : MsgBox "60.vbs", , "0041 :: " & WScript.ScriptName
If Nach60 = 0 Then Exit Do ' Alles abgearbeitet
If Intervall = "s" Then WScript.Sleep 1*1000 ' 1s
If Intervall = "n" Then WScript.Sleep 60*1000 ' 1min
Loop
MsgBox "Das wars!", , "0050 :: " & WScript.ScriptName
#########################################################################
>>> datensicherung.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
' File: Datensicherung.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Gemäß der Verzeichnisliste "Datensicherung.txt" wird auf
' dem ZielLaufwerk (1. zeile in "Datensicherung.txt") eine
' komprimierte Datei (Verzeichnis) mit dem Tagesdatum
' erstellt, in der alle Dateien der Verzeichnisse mit
' Unterverzeichnissen, wie in "Datensicherung.txt" gelistet,
' enthalten sind.
' Zeilen, die mit einem Leerschrit, einem Semikolon oder
' einem Apostroph beginnen werden ignoriert.
'************************************************************
Option Explicit
Dim fso, WSHShell, WSHNetzWerk, WSHLaufWerk, oArgs
Dim i, FileOut, FileOut1, FileIn, TXT, TXT1, Text, ZielOK, VerzOK, Problem, Menge, Pwd
Dim Zeit, ZielVerz, VerzListe, VerzNr
Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
Set Prog_PP = nothing
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
Pwd = ""
' Passwort definieren
' => nächste Zeile frei geben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PwdAbfrage ' Function Aufruf
LogDatei ( vbCRLF & now() & " - " & UCase(WScript.ScriptName) & " gestartet"& vbCRLF & "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ " )
' Prüfen, ob VerzListe-Datei existiert;
' wenn nicht: anlegen und ausfüllen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' VerzListe = "Datensicherung.txt"
VerzListe = fso.GetBaseName( WScript.ScriptName ) & ".txt"
if not fso.FileExists( VerzListe ) then
Set FileOut = fso.OpenTextFile( VerzListe, 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( WScript.ScriptName, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = "'" then Exit Do
FileOut.WriteLine( TXT )
Loop
FileOut.WriteLine( "' Bitte jetzt vervollständigen:" )
FileOut.WriteLine( "' 1. freie Zeile: Ziel-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' 2. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' ?. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
Set FileIn = nothing
Set FileOut = nothing
WSHShell.run VerzListe, 4, True
End If
' Prüfen, ob VerzListe korrekt ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - ermittelt das Zielverzeichnis der Datensicherungen
' - Datensicherung.tmp enthält Liste der zu sichernden Verzichnisse
ParameterAbfrage ' Function Aufruf
' Im Zielverzeichnis wird DatumVerzeichnis mit lfd. Nr. erzeugt
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = Datumverzeichnis ( ZielVerz ) ' Function Aufruf
Set FileIn = fso.OpenTextFile( fso.GetBaseName( VerzListe ) & ".tmp", 1 ) ' Datei zum Lesen öffnen
Menge = 0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = CStr( FileIn.Readline ) ' eine Zeile lesen
if Len( TXT ) < 8 Then Text = TXT & vbTab
if not Len( TXT ) < 8 Then Text = TXT
if not fso.FolderExists( TXT ) then
LogDatei ( vbCRLF & "!!! " & TXT & " nicht vorhanden. ")
Else
' Menge = Menge + CLng(fso.GetFolder( TXT ).size)
Menge = Menge + fso.GetFolder( TXT ).size
Text = Text & vbTab & FormatNumber( fso.GetFolder( TXT ).size/1024 , 1) & " kByte" & vbTab & " zu sichern"
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).VolumeName
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).ShareName
LogDatei ( Text )
Text = Replace( Left ( TXT, 1) & "" & Mid ( TXT, 3) , "\" , "²")
'_______________________________________________________________
'Für die Verwendung von XCOPY folgende beiden Zeilen frei geben
' Text = "xcopy """ & TXT & "\*.*"" """ & ZielVerz & "\" & Text & "\*.*"" /S/E/V "
'_______________________________________________________________
'Für die Verwendung von ROBOCOPY folgende Zeile frei geben
' Text = "robocopy """ & TXT & """ """ & ZielVerz & "\" & Text & """ /S /E /sec /w:1 /r:1 /log:" & ZielVerz & "\" & Text & ".log "
'_______________________________________________________________
'Für die Verwendung von RAR zwei Zeilen frei geben
' If Pwd = "" Then Text = "rar.exe a -ad -m5 -ap" & " -sfx """ & ZielVerz & "\" & Text & """ """ & TXT & """"
' If not Pwd = "" Then Text = "rar.exe a -ad -m5 -ap -hp" & Pwd & " -sfx """ & ZielVerz & "\" & Text & """.rar """ & TXT & """"
TXT1 = ""
If fso.FileExists( "7z.sfx" ) Then TXT1 = " -sfx7z.sfx"
'_______________________________________________________________
'Für die Verwendung von 7-Zip zwei Zeilen frei geben
If Pwd = "" Then Text = "7z.exe a" & TXT1 & " -r" & " """ & ZielVerz & "\" & Text & ".exe"" """ & TXT & """"
If not Pwd = "" Then Text = "7z.exe a" & TXT1 & " -r -p" & Pwd & " """ & ZielVerz & "\" & Text & ".exe"" """ & TXT & """"
' MsgBox text, , "115 :: " : WSCript.Quit
'_______________________________________________________________
'Wahlweise die RunBat oder WSHShell.Run Zeile frei geben
' RunBat ( Text ) ' Function Aufruf
WSHShell.run "%comspec% /k " & Text , , True
' WSHShell.run Text , 8, True
' Passwort für LogDatei entfernen
Text = Replace( Text, Pwd, "~-_Pwd_-~" )
LogDatei Text & vbTab & " . . . abgeschlossen. " & vbCRLF
End If
Loop
LogDatei ( now() & " - " & UCase(WScript.ScriptName) & " beendet" )
LogDatei ( FormatNumber( Menge/1024, 1) & " kByte wurden in " & FormatNumber( fso.GetFolder( ZielVerz ).size/1024 , 1) & " kByte gepackt und nach " & ZielVerz & " gesichert. ")
Set FileIn = nothing
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' LogDatei anzeigen (und an das Ende springen)
' => nächste Zeile frei geben
' LogDateiAnzeige
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Erstelltes Zielverzeichnis mit gesicherten Daten anzeigen
' => nächste Zeile frei geben
WSHShell.run ZielVerz, 1
WScript.Quit
' **************************************************************
Function CopyNachA (Datei) ' Anfang
' **************************************************************
' Archiv nach A: kopieren?
Dim TXT, Text
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
TXT = Datei
If not fso.GetFile( Datei ).Size < 1457664-2048 then
Text = Datei & vbCRLF & "ist mit " & Int( fso.GetFile( Datei ).Size/1024/1024 ) & " MB zu groß für eine Diskette!"
WshShell.Popup Text, 10, WScript.ScriptName, 4096
Exit Function
End If
Text = "Soll das erstellte Archiv " & vbCRLF & vbCRLF
Text = Text & LCase( Datei ) & " (" & FormatNumber( fso.GetFile( Datei ).Size,1) & " Byte)" & vbCRLF & vbCRLF
Text = Text & "auf eine Diskette in A: kopiert werden? [N] nach 10 Sekunden."
If not vbYes = WshShell.Popup( Text, 25, WScript.ScriptName, 4096+4+32) Then Exit Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Diskette bereit?
If not fso.GetDrive( "a:" ).IsReady Then WshShell.Popup "Laufwerk A: ist nicht bereit!", 10, WScript.ScriptName, 4096
If not fso.GetDrive( "a:" ).IsReady Then Exit Function
If fso.FileExists ( "A:\" & fso.GetBaseName( Datei ) & ".exe" ) then fso.DeleteFile "A:\" & fso.GetBaseName( Datei ) & ".exe", true
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Diskette mit genügend freien Speicher?
If not fso.GetFile( Datei ).Size < fso.GetDrive( "a:" ).FreeSpace-1024 then
Text = "Auf der Diskette in A: ist nicht genügend Platz!" & vbCRLF
Text = Text & "Soll die Diskette formatiert werden?"
If vbYes = WshShell.Popup( Text, 25, WScript.ScriptName, 4096+4+32) Then
WSHShell.Run "format a: /F:1440 /Q /V:DISK1440", , True
' WSHShell.Run "%comspec% /k format a: /F:1440 /U /V:DISK1440", , True
End If
End If
If not fso.GetFile( Datei ).Size < fso.GetDrive( "a:" ).FreeSpace-1024 then Exit Function
PopsUp Datei & vbCRLF & vbCRLF & "wird z.Z. nach A: kopiert . . .", 90
fso.CopyFile Datei , "A:\" & fso.GetBaseName( Datei ) & ".exe"
PopsUp "", 0
' If fso.FileExists( "A:\" & fso.GetBaseName( Datei ) & ".exe" ) then
' PopsUp "A:\" & fso.GetBaseName( Datei ) & ".exe" & vbCRLF & vbCRLF & "wurde erstellt.!", 10
' End If
End Function ' CopyNachA (Datei)
' **************************************************************
' **************************************************************
Function ParameterAbfrage
' **************************************************************
' VerzeichnisListe zeilenweise lesen und prüfen
i = 0
Problem = ""
ZielOK = ""
VerzOK = ""
VerzNr = 0
Text = ""
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
' Bemerkungszeilen nicht prüfen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
ZielOK = "ok"
i = i + Len(TXT) +2
If not fso.FolderExists( TXT ) Then
ZielOK = "fehlt"
If VerzNr < 1 then FileOut.WriteLine( TXT )
If not VerzNr < 1 then FileOut.WriteLine( ";###" & ZielOk & " " & TXT )
Problem = "ja"
Else
FileOut.WriteLine( TXT )
End If
' Zeilen für MsgBox in Text sammeln; erste Zeile enthält ZielVerzeichnis
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Text = "" Then
ZielVerz = TXT
VerzOK = ZielOK
Text = "Nach " & ZielVerz & " (" & ZielOK & ") werden folgende Verzeichnisse gesichert (kopiert): " & vbTab & vbCRLF
' Zeilen für MsgBox in Text sammeln; jede weitere Zeile enthält zu sichernde Verzeichnisse
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Else
VerzNr = VerzNr +1
if i < 400 then
Text = Text & vbCRLF & VerzNr & vbTab & ZielOK & vbTab & " " & TXT
End If
End If
Else
FileOut.WriteLine( TXT )
End If
Loop
Set FileIn = nothing
Set FileOut = nothing
Text = Text & vbCRLF & " " & VerzNr & " Verzeichnisse insgesamt."
' Problem = "nEIn"
If UCase( left(Problem,2) ) = "JA" Then
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sollten angepasst werden, da nicht alle Verzeichnisse " & vbCRLF & "vorhanden sind."
Else
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sind soweit ok, können aber angepasst werden."
End If
If not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
Text = Text & vbCRLF & vbCRLF & UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
End If
Text = Text & vbCRLF & vbCRLF & "Parameter korrigieren oder Skript abbrechen? [No] in 10sec."
TXT = WshShell.Popup(Text, 5, WScript.ScriptName, 4096+3+32)
If TXT = -1 AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
' wenn keine Taste gedrückt wurde
Text = UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
Text = Text & vbCRLF & vbCRLF & UCase("Das Skript wird ohne Datensicherung beendet!")
LogDatei ( Text ) ' Sub Aufruf
WshShell.Popup Text, 10, WScript.ScriptName, 64+4096
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
If TXT = vbNo AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
MsgBox UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!"), 4096+64, WScript.ScriptName
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbYes then
fso.CopyFile fso.GetBaseName( VerzListe) & ".tmp", VerzListe
WSHShell.run VerzListe, , True
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbCancel then
WshShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName, 64+4096
Text = UCase("Das Skript wurde abgebrochen = keine Datensicherung!")
LogDatei ( Text ) ' Sub Aufruf
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
i = 0
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
If i > 0 then FileOut.WriteLine( TXT )
i = i +1
End If
Loop
Set FileIn = nothing
Set FileOut = nothing
End Function ' ParameterAbfrage
' **************************************************************
' **************************************************************
Function Datumverzeichnis ( ZielVerz )
' **************************************************************
' legt im ZielVerzeichhnis ein Datumverzeichnis mit lfd.
' Nummer an: (k:\siceherer\)02-12-03_0
Zeit = now()
' zweistellige Jahreszahl
Datumverzeichnis = Right(Year(Zeit),2)
' zweistellige Monatszahl
If Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Month(Zeit)
If not Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Month(Zeit)
' zweistellige Tageszahl
If Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Day(Zeit)
If not Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Day(Zeit)
' zweistellige Stundezahl
' If Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_0" & Hour(Zeit)
' If not Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_" & Hour(Zeit)
' zweistellige Minutenzahl
' If Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' If not Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' zweistellige Sekundenzahl
' If Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Second(Zeit)
' If not Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'" & Second(Zeit)
' if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis ) then
' fso.CreateFolder( ZielVerz & "\" & Datumverzeichnis )
' Exit Function
' End If
for i = 0 to 99
If i < 1 then i = "0"
If i < 10 then i = "0" & CStr(i) ' zweistellig machen
If not i < 10 then i = "" & CStr(i) ' zweistellig lassen
if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis & "." & i ) then
Datumverzeichnis = ZielVerz & "\" & Datumverzeichnis & "." & i
fso.CreateFolder( Datumverzeichnis )
Exit Function
End If
next
End Function ' Datumverzeichnis ( ZielVerz )
' **************************************************************
' **************************************************************
Function RunBat ( BatTXT )
' **************************************************************
' erzeugt eine .BAT Datei mit 2x Pause und führt diese aus
' MsgBox BatTXT
TXT1 = "bsp.bat"
Set FileOut1 = fso.OpenTextFile( TXT1 , 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
FileOut1.WriteLine( "@echo off")
FileOut1.WriteLine( "@echo " & BatTXT )
FileOut1.WriteLine( "@" & BatTXT )
FileOut1.WriteLine( "@pause")
FileOut1.WriteLine( "@pause")
Set FileOut1 = nothing
WSHShell.run "%comspec% /c " & TXT1 , , True
End Function ' RunBat ( BatTXT )
' **************************************************************
' **************************************************************
Sub LogDatei (LogTxt)
' **************************************************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( fso.GetBaseName( WScript.ScriptName ) & ".log", 8, true)
' fileOut.WriteLine (vbCRLF & Now() )
fileOut.WriteLine (LogTxt)
Set FileOut = Nothing
End Sub ' LogDatei
' **************************************************************
' **************************************************************
Sub PwdAbfrage
' **************************************************************
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Pwd = oArgs.item(i)
Exit For ' ein Argument reicht
Next
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
' If not Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4096+4+32)
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("nicht mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
If Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4096+4+32)
Text = "Mit welchen Passwort sollen die Dateien der Datensicherung geschützt werden?"
Text = Text & vbCRLF & "Das Passwort darf ! KEINE ! Leerzeichen enthalten!"
If TXT = vbNo then Pwd = InputBox (Text, WScript.ScriptName)
End Sub ' PwdAbfrage
' **************************************************************
' **************************************************************
Sub LogDateiAnzeige
' **************************************************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
WSHShell.run "notepad " & fso.GetBaseName( WScript.ScriptName ) & ".log"
On Error Resume Next
WScript.Sleep 500
WSHShell.SendKeys "^{End}" ' ans Ende springen
WScript.Sleep 500
WSHShell.SendKeys "{Up}" ' eine Zeile hoch
WScript.Sleep 500
WSHShell.SendKeys "+{Down}" ' mit gedrückter Shift-Taste eine Zeile nach unten
' markiert die letzte Zeile
' WScript.Sleep 20000
' WSHShell.SendKeys "%{F4}" ' schließt das aktuelle Fenster
On Error GoTo 0
WScript.Quit
End Sub ' LogDateiAnzeige
' **************************************************************
' **************************************************************
Function PopsUp ( TxT, Dauer ) ' Aufruf v3.7 - http://dieseyer.de
' **************************************************************
' ACHTUNG! Ausserhalb und ver dem ersten Aufruf dieser Prozedur
' muss einmal "Set Prog_PP = nothing" stehen, sonst wird es
' mit dem "prog.terminate" innerhalb der Prozedur nichts!
'
' ACHTUNG! Alle Variablen müssen ausserhalb dieser Prozedur
' deklariert werden (also folgende Zeilen an den Skript-Anafng):
' Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
' Set Prog_PP = nothing
'
' Die Vorversion hat (versucht) das PopUp über AppActivate
' zu schließen.
Set Fso_PP = CreateObject("Scripting.FileSystemObject")
' VBSDatei_PP = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
VBSDatei_PP = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
On Error Resume Next
Prog_PP.terminate
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
If Txt = "" then
' On Error Resume Next
IF Fso_PP.FileExists(VBSDatei_PP) then Fso_PP.DeleteFile(VBSDatei_PP) ' löscht das MSG-VBScript
' On Error GoTo 0
Exit Function
End If
Txt = Replace( Txt, vbCRLF, """ & vbCRLF & """ )
Set FileOut_PP = Fso_PP.OpenTextFile(VBSDatei_PP, 2, true) ' MSG-VBScript öffnen mit neu anlegen
FileOut_PP.WriteLine "WScript.CreateObject(""WScript.Shell"").Popup """ & Txt & """ , " & Dauer & ", """ & Fso_PP.GetFileName( VBSDatei_PP ) & " "" "
FileOut_PP.Close
Set FileOut_PP = Nothing
Set Prog_PP = createObject("WScript.Shell").exec( "WScript " & VBSDatei_PP )
Set Fso_PP = Nothing
End Function ' PopsUp v3.7 - http://dieseyer.de
' **************************************************************
#########################################################################
>>> datensicherung.vbs <<<
'*** v9.A *** www.dieseyer.de ******************************
' File: Datensicherung.vbs
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' Gemäß der Verzeichnisliste "Datensicherung.txt" wird auf
' dem ZielLaufwerk (1. zeile in "Datensicherung.txt") eine
' komprimierte Datei (Verzeichnis) mit dem Tagesdatum
' erstellt, in der alle Dateien der Verzeichnisse mit
' Unterverzeichnissen, wie in "Datensicherung.txt" gelistet,
' enthalten sind.
' Zeilen, die mit einem Leerschrit, einem Semikolon oder
' einem Apostroph beginnen werden ignoriert.
'************************************************************
Option Explicit
Dim fso, WSHShell, WSHNetzWerk, WSHLaufWerk, oArgs
Dim i, FileOut, FileOut1, FileIn, TXT, TXT1, Text, ZielOK, VerzOK, Problem, Menge, Pwd
Dim Zeit, ZielVerz, VerzListe, VerzNr
Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
Set Prog_PP = nothing
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
Pwd = ""
' Passwort definieren
' => nächste Zeile frei geben
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
PwdAbfrage ' Function Aufruf
LogDatei ( vbCRLF & now() & " - " & UCase(WScript.ScriptName) & " gestartet"& vbCRLF & "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ " )
' Prüfen, ob VerzListe-Datei existiert;
' wenn nicht: anlegen und ausfüllen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' VerzListe = "Datensicherung.txt"
VerzListe = fso.GetBaseName( WScript.ScriptName ) & ".txt"
if not fso.FileExists( VerzListe ) then
Set FileOut = fso.OpenTextFile( VerzListe, 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( WScript.ScriptName, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = "'" then Exit Do
FileOut.WriteLine( TXT )
Loop
FileOut.WriteLine( "' Bitte jetzt vervollständigen:" )
FileOut.WriteLine( "' 1. freie Zeile: Ziel-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' 2. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
FileOut.WriteLine( "' ?. freie Zeile: zu sicherndes Quell-Verzeichnis für Datensicherung" )
Set FileIn = nothing
Set FileOut = nothing
WSHShell.run VerzListe, 4, True
End If
' Prüfen, ob VerzListe korrekt ist
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - ermittelt das Zielverzeichnis der Datensicherungen
' - Datensicherung.tmp enthält Liste der zu sichernden Verzichnisse
ParameterAbfrage ' Function Aufruf
' Im Zielverzeichnis wird DatumVerzeichnis mit lfd. Nr. erzeugt
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielVerz = Datumverzeichnis ( ZielVerz ) ' Function Aufruf
Set FileIn = fso.OpenTextFile( fso.GetBaseName( VerzListe ) & ".tmp", 1 ) ' Datei zum Lesen öffnen
Menge = 0
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = CStr( FileIn.Readline ) ' eine Zeile lesen
if Len( TXT ) < 8 Then Text = TXT & vbTab
if not Len( TXT ) < 8 Then Text = TXT
if not fso.FolderExists( TXT ) then
LogDatei ( vbCRLF & "!!! " & TXT & " nicht vorhanden. ")
Else
' Menge = Menge + CLng(fso.GetFolder( TXT ).size)
Menge = Menge + fso.GetFolder( TXT ).size
Text = Text & vbTab & FormatNumber( fso.GetFolder( TXT ).size/1024 , 1) & " kByte" & vbTab & " zu sichern"
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).VolumeName
Text = Text & vbTab & fso.getDrive( Left ( TXT, 2 ) ).ShareName
LogDatei ( Text )
Text = Replace( Left ( TXT, 1) & "" & Mid ( TXT, 3) , "\" , "²")
'_______________________________________________________________
'Für die Verwendung von XCOPY folgende beiden Zeilen frei geben
' Text = "xcopy """ & TXT & "\*.*"" """ & ZielVerz & "\" & Text & "\*.*"" /S/E/V "
'_______________________________________________________________
'Für die Verwendung von ROBOCOPY folgende Zeile frei geben
' Text = "robocopy """ & TXT & """ """ & ZielVerz & "\" & Text & """ /S /E /sec /w:1 /r:1 /log:" & ZielVerz & "\" & Text & ".log "
'_______________________________________________________________
'Für die Verwendung von RAR zwei Zeilen frei geben
' If Pwd = "" Then Text = "rar.exe a -ad -m5 -ap" & " -sfx """ & ZielVerz & "\" & Text & """ """ & TXT & """"
' If not Pwd = "" Then Text = "rar.exe a -ad -m5 -ap -hp" & Pwd & " -sfx """ & ZielVerz & "\" & Text & """.rar """ & TXT & """"
TXT1 = ""
If fso.FileExists( "7z.sfx" ) Then TXT1 = " -sfx7z.sfx"
'_______________________________________________________________
'Für die Verwendung von 7-Zip zwei Zeilen frei geben
If Pwd = "" Then Text = "7z.exe a" & TXT1 & " -r" & " """ & ZielVerz & "\" & Text & ".exe"" """ & TXT & """"
If not Pwd = "" Then Text = "7z.exe a" & TXT1 & " -r -p" & Pwd & " """ & ZielVerz & "\" & Text & ".exe"" """ & TXT & """"
' MsgBox text, , "115 :: " : WSCript.Quit
'_______________________________________________________________
'Wahlweise die RunBat oder WSHShell.Run Zeile frei geben
' RunBat ( Text ) ' Function Aufruf
WSHShell.run "%comspec% /k " & Text , , True
' WSHShell.run Text , 8, True
' Passwort für LogDatei entfernen
Text = Replace( Text, Pwd, "~-_Pwd_-~" )
LogDatei Text & vbTab & " . . . abgeschlossen. " & vbCRLF
End If
Loop
LogDatei ( now() & " - " & UCase(WScript.ScriptName) & " beendet" )
LogDatei ( FormatNumber( Menge/1024, 1) & " kByte wurden in " & FormatNumber( fso.GetFolder( ZielVerz ).size/1024 , 1) & " kByte gepackt und nach " & ZielVerz & " gesichert. ")
Set FileIn = nothing
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' LogDatei anzeigen (und an das Ende springen)
' => nächste Zeile frei geben
' LogDateiAnzeige
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Erstelltes Zielverzeichnis mit gesicherten Daten anzeigen
' => nächste Zeile frei geben
WSHShell.run ZielVerz, 1
WScript.Quit
' **************************************************************
Function CopyNachA (Datei) ' Anfang
' **************************************************************
' Archiv nach A: kopieren?
Dim TXT, Text
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
TXT = Datei
If not fso.GetFile( Datei ).Size < 1457664-2048 then
Text = Datei & vbCRLF & "ist mit " & Int( fso.GetFile( Datei ).Size/1024/1024 ) & " MB zu groß für eine Diskette!"
WshShell.Popup Text, 10, WScript.ScriptName, 4096
Exit Function
End If
Text = "Soll das erstellte Archiv " & vbCRLF & vbCRLF
Text = Text & LCase( Datei ) & " (" & FormatNumber( fso.GetFile( Datei ).Size,1) & " Byte)" & vbCRLF & vbCRLF
Text = Text & "auf eine Diskette in A: kopiert werden? [N] nach 10 Sekunden."
If not vbYes = WshShell.Popup( Text, 25, WScript.ScriptName, 4096+4+32) Then Exit Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Diskette bereit?
If not fso.GetDrive( "a:" ).IsReady Then WshShell.Popup "Laufwerk A: ist nicht bereit!", 10, WScript.ScriptName, 4096
If not fso.GetDrive( "a:" ).IsReady Then Exit Function
If fso.FileExists ( "A:\" & fso.GetBaseName( Datei ) & ".exe" ) then fso.DeleteFile "A:\" & fso.GetBaseName( Datei ) & ".exe", true
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Diskette mit genügend freien Speicher?
If not fso.GetFile( Datei ).Size < fso.GetDrive( "a:" ).FreeSpace-1024 then
Text = "Auf der Diskette in A: ist nicht genügend Platz!" & vbCRLF
Text = Text & "Soll die Diskette formatiert werden?"
If vbYes = WshShell.Popup( Text, 25, WScript.ScriptName, 4096+4+32) Then
WSHShell.Run "format a: /F:1440 /Q /V:DISK1440", , True
' WSHShell.Run "%comspec% /k format a: /F:1440 /U /V:DISK1440", , True
End If
End If
If not fso.GetFile( Datei ).Size < fso.GetDrive( "a:" ).FreeSpace-1024 then Exit Function
PopsUp Datei & vbCRLF & vbCRLF & "wird z.Z. nach A: kopiert . . .", 90
fso.CopyFile Datei , "A:\" & fso.GetBaseName( Datei ) & ".exe"
PopsUp "", 0
' If fso.FileExists( "A:\" & fso.GetBaseName( Datei ) & ".exe" ) then
' PopsUp "A:\" & fso.GetBaseName( Datei ) & ".exe" & vbCRLF & vbCRLF & "wurde erstellt.!", 10
' End If
End Function ' CopyNachA (Datei)
' **************************************************************
' **************************************************************
Function ParameterAbfrage
' **************************************************************
' VerzeichnisListe zeilenweise lesen und prüfen
i = 0
Problem = ""
ZielOK = ""
VerzOK = ""
VerzNr = 0
Text = ""
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
' Bemerkungszeilen nicht prüfen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
ZielOK = "ok"
i = i + Len(TXT) +2
If not fso.FolderExists( TXT ) Then
ZielOK = "fehlt"
If VerzNr < 1 then FileOut.WriteLine( TXT )
If not VerzNr < 1 then FileOut.WriteLine( ";###" & ZielOk & " " & TXT )
Problem = "ja"
Else
FileOut.WriteLine( TXT )
End If
' Zeilen für MsgBox in Text sammeln; erste Zeile enthält ZielVerzeichnis
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Text = "" Then
ZielVerz = TXT
VerzOK = ZielOK
Text = "Nach " & ZielVerz & " (" & ZielOK & ") werden folgende Verzeichnisse gesichert (kopiert): " & vbTab & vbCRLF
' Zeilen für MsgBox in Text sammeln; jede weitere Zeile enthält zu sichernde Verzeichnisse
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Else
VerzNr = VerzNr +1
if i < 400 then
Text = Text & vbCRLF & VerzNr & vbTab & ZielOK & vbTab & " " & TXT
End If
End If
Else
FileOut.WriteLine( TXT )
End If
Loop
Set FileIn = nothing
Set FileOut = nothing
Text = Text & vbCRLF & " " & VerzNr & " Verzeichnisse insgesamt."
' Problem = "nEIn"
If UCase( left(Problem,2) ) = "JA" Then
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sollten angepasst werden, da nicht alle Verzeichnisse " & vbCRLF & "vorhanden sind."
Else
Text = Text & vbCRLF & vbCRLF & "Die obigen Parameter sind soweit ok, können aber angepasst werden."
End If
If not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
Text = Text & vbCRLF & vbCRLF & UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
End If
Text = Text & vbCRLF & vbCRLF & "Parameter korrigieren oder Skript abbrechen? [No] in 10sec."
TXT = WshShell.Popup(Text, 5, WScript.ScriptName, 4096+3+32)
If TXT = -1 AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
' wenn keine Taste gedrückt wurde
Text = UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!")
Text = Text & vbCRLF & vbCRLF & UCase("Das Skript wird ohne Datensicherung beendet!")
LogDatei ( Text ) ' Sub Aufruf
WshShell.Popup Text, 10, WScript.ScriptName, 64+4096
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
If TXT = vbNo AND not UCase(Left( VerzOK, 2)) = "OK" Then ' Meldung, wenn ZielVerzeichnis nicht vorhanden
MsgBox UCase("Das Zielverzeichnis " & ZielVerz & " zur Datensicherung existiert nicht!"), 4096+64, WScript.ScriptName
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbYes then
fso.CopyFile fso.GetBaseName( VerzListe) & ".tmp", VerzListe
WSHShell.run VerzListe, , True
ParameterAbfrage ' Function Aufruf
End If
If TXT = vbCancel then
WshShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName, 64+4096
Text = UCase("Das Skript wurde abgebrochen = keine Datensicherung!")
LogDatei ( Text ) ' Sub Aufruf
LogDateiAnzeige ' Sub Aufruf
WScript.Quit
End If
i = 0
Set FileOut = fso.OpenTextFile( fso.GetBaseName( VerzListe) & ".tmp", 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
Set FileIn = FSO.OpenTextFile( VerzListe, 1 ) ' Datei zum Lesen öffnen
Do While Not (FileIn.atEndOfStream) ' wenn Datei nicht zu ende ist, weiter machen
TXT = FileIn.Readline ' eine Zeile lesen
If not Left ( TXT, 1 ) = ";" AND not Left ( TXT, 1 ) = " " AND not Left ( TXT, 1 ) = "'" then
' wenn die Zeile nicht mit . . . beginnt
If i > 0 then FileOut.WriteLine( TXT )
i = i +1
End If
Loop
Set FileIn = nothing
Set FileOut = nothing
End Function ' ParameterAbfrage
' **************************************************************
' **************************************************************
Function Datumverzeichnis ( ZielVerz )
' **************************************************************
' legt im ZielVerzeichhnis ein Datumverzeichnis mit lfd.
' Nummer an: (k:\siceherer\)02-12-03_0
Zeit = now()
' zweistellige Jahreszahl
Datumverzeichnis = Right(Year(Zeit),2)
' zweistellige Monatszahl
If Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Month(Zeit)
If not Len(Month(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Month(Zeit)
' zweistellige Tageszahl
If Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-0" & Day(Zeit)
If not Len(Day(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "-" & Day(Zeit)
' zweistellige Stundezahl
' If Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_0" & Hour(Zeit)
' If not Len(Hour(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "_" & Hour(Zeit)
' zweistellige Minutenzahl
' If Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' If not Len(Minute(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Minute(Zeit)
' zweistellige Sekundenzahl
' If Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'0" & Second(Zeit)
' If not Len(Second(Zeit)) = 1 then Datumverzeichnis = Datumverzeichnis & "'" & Second(Zeit)
' if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis ) then
' fso.CreateFolder( ZielVerz & "\" & Datumverzeichnis )
' Exit Function
' End If
for i = 0 to 99
If i < 1 then i = "0"
If i < 10 then i = "0" & CStr(i) ' zweistellig machen
If not i < 10 then i = "" & CStr(i) ' zweistellig lassen
if not fso.FolderExists( ZielVerz & "\" & Datumverzeichnis & "." & i ) then
Datumverzeichnis = ZielVerz & "\" & Datumverzeichnis & "." & i
fso.CreateFolder( Datumverzeichnis )
Exit Function
End If
next
End Function ' Datumverzeichnis ( ZielVerz )
' **************************************************************
' **************************************************************
Function RunBat ( BatTXT )
' **************************************************************
' erzeugt eine .BAT Datei mit 2x Pause und führt diese aus
' MsgBox BatTXT
TXT1 = "bsp.bat"
Set FileOut1 = fso.OpenTextFile( TXT1 , 2, true) ' Datei zum Erweitern öffnen (notfals anlegen)
FileOut1.WriteLine( "@echo off")
FileOut1.WriteLine( "@echo " & BatTXT )
FileOut1.WriteLine( "@" & BatTXT )
FileOut1.WriteLine( "@pause")
FileOut1.WriteLine( "@pause")
Set FileOut1 = nothing
WSHShell.run "%comspec% /c " & TXT1 , , True
End Function ' RunBat ( BatTXT )
' **************************************************************
' **************************************************************
Sub LogDatei (LogTxt)
' **************************************************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set FileOut = fso.OpenTextFile( fso.GetBaseName( WScript.ScriptName ) & ".log", 8, true)
' fileOut.WriteLine (vbCRLF & Now() )
fileOut.WriteLine (LogTxt)
Set FileOut = Nothing
End Sub ' LogDatei
' **************************************************************
' **************************************************************
Sub PwdAbfrage
' **************************************************************
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
Pwd = oArgs.item(i)
Exit For ' ein Argument reicht
Next
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
' If not Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4096+4+32)
Text = "Die Dateien der Datensicherung werden " & vbCRLF & vbCRLF & UCase("nicht mit einem Passwort geschützt.")
Text = Text & vbCRLF & vbCRLF & "Ist das so gewollt? <Yes> in 15sec."
If Pwd = "" then TXT = WshShell.Popup( Text, 15, WScript.ScriptName, 4096+4+32)
Text = "Mit welchen Passwort sollen die Dateien der Datensicherung geschützt werden?"
Text = Text & vbCRLF & "Das Passwort darf ! KEINE ! Leerzeichen enthalten!"
If TXT = vbNo then Pwd = InputBox (Text, WScript.ScriptName)
End Sub ' PwdAbfrage
' **************************************************************
' **************************************************************
Sub LogDateiAnzeige
' **************************************************************
Dim FileOut, fso
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
WSHShell.run "notepad " & fso.GetBaseName( WScript.ScriptName ) & ".log"
On Error Resume Next
WScript.Sleep 500
WSHShell.SendKeys "^{End}" ' ans Ende springen
WScript.Sleep 500
WSHShell.SendKeys "{Up}" ' eine Zeile hoch
WScript.Sleep 500
WSHShell.SendKeys "+{Down}" ' mit gedrückter Shift-Taste eine Zeile nach unten
' markiert die letzte Zeile
' WScript.Sleep 20000
' WSHShell.SendKeys "%{F4}" ' schließt das aktuelle Fenster
On Error GoTo 0
WScript.Quit
End Sub ' LogDateiAnzeige
' **************************************************************
' **************************************************************
Function PopsUp ( TxT, Dauer ) ' Aufruf v3.7 - http://dieseyer.de
' **************************************************************
' ACHTUNG! Ausserhalb und ver dem ersten Aufruf dieser Prozedur
' muss einmal "Set Prog_PP = nothing" stehen, sonst wird es
' mit dem "prog.terminate" innerhalb der Prozedur nichts!
'
' ACHTUNG! Alle Variablen müssen ausserhalb dieser Prozedur
' deklariert werden (also folgende Zeilen an den Skript-Anafng):
' Dim Prog_PP, FSO_PP, FileOut_PP, VBSDatei_PP
' Set Prog_PP = nothing
'
' Die Vorversion hat (versucht) das PopUp über AppActivate
' zu schließen.
Set Fso_PP = CreateObject("Scripting.FileSystemObject")
' VBSDatei_PP = WSHShell.ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
VBSDatei_PP = WScript.CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & Fso_PP.GetBaseName( WScript.ScriptName ) & "-MSG.VBS"
On Error Resume Next
Prog_PP.terminate
' If not err.Number = 0 then MsgBox err.Description
On Error GoTo 0
If Txt = "" then
' On Error Resume Next
IF Fso_PP.FileExists(VBSDatei_PP) then Fso_PP.DeleteFile(VBSDatei_PP) ' löscht das MSG-VBScript
' On Error GoTo 0
Exit Function
End If
Txt = Replace( Txt, vbCRLF, """ & vbCRLF & """ )
Set FileOut_PP = Fso_PP.OpenTextFile(VBSDatei_PP, 2, true) ' MSG-VBScript öffnen mit neu anlegen
FileOut_PP.WriteLine "WScript.CreateObject(""WScript.Shell"").Popup """ & Txt & """ , " & Dauer & ", """ & Fso_PP.GetFileName( VBSDatei_PP ) & " "" "
FileOut_PP.Close
Set FileOut_PP = Nothing
Set Prog_PP = createObject("WScript.Shell").exec( "WScript " & VBSDatei_PP )
Set Fso_PP = Nothing
End Function ' PopsUp v3.7 - http://dieseyer.de
' **************************************************************
#########################################################################
http://dieseyer.de • all rights reserved • © 2011 v11.4