http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** 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 )
http://dieseyer.de • all rights reserved • © 2011 v11.4