'*** 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 "" FileOut.WriteLine "" FileOut.WriteLine "" FileOut.WriteLine "" FileOut.WriteLine "" FileOut.WriteLine "" FileOut.WriteLine "" ' FileOut.WriteLine "
"
  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 ) ' & "
" ' 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 "" & Mid( Txt, 17 ) & "   " & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17 ), "|" ) & "
" FileOut.WriteLine "" & Mid( Txt, 17 ) & "   " & String( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17, 2 ) * Zoom , "|" ) & "
" ' FileOut.WriteLine "" & Mid( Txt, 17 ) & "   " & String( ( ( Mid( Txt, InStr( Mid( Txt, 17), vbTab ) + 17, 2) - 30 ) * 4 ), "|" ) & "
" Tst = Txt Else arrDaten(i) = "" End If Next ' FileOut.WriteLine "
" FileOut.WriteLine "" FileOut.WriteLine "" 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: ' ' 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, "" ) > 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!): ' ' < ' 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 = "" 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 )