'Copyright (C) 2007 Phil Tipping, www.philizound.co.uk
'Converts raw data from MonitorNetwork log file into weekly bar chart
'Process:-
'  Run Word
'  Click File, Open (Files of type: All Files) & open log file
'  Click Tools, Macro, Macros...
'  If macro AnalyseNetLog exists then select it & click Run, otherwise:-
'    (Note: organising existing macros is beyond the scope of these guidelines)
'    Type xxx into the Macro Name box, then click Create
'    This should open the Visual Basic Editor & you'll see a skeleton macro
'        Sub xxx()
'        ....
'        End Sub
'    Delete the whole skeleton: Sub, End Sub and everything in between
'    Copy/paste the whole contents of this file into the Editor
'    Close Editor to return to the log file in Word
'    Click Tools, Macro, Macros...
'    Select macro AnalyseNetLog & click Run
'
'Macro will create & save a new document with same root name as log file

'Version 3.00 21/11/07

Sub AnalyseNetLog()
    'assumes log file to be analysed is already open
    Const intWeeksPerPage = 4
    Const intDaysPerWeek = 7

    Dim strLogName
    Dim strDocName
    
    SetFileNames strLogName, strDocName
    SetupDoc strDocName

    ProcessLog strLogName, strDocName, intWeeksPerPage, intDaysPerWeek
    Windows(strDocName).Activate
    SaveDoc strDocName
End Sub
Sub SetFileNames(ByRef strLogName, ByRef strDocName)
    Dim intLength
    Dim intExtnPosn
    Dim strPathName
    Dim intPosn
    Dim strFullName
    
    strFullName = ActiveDocument.FullName
    
    'split into path and file names
    intLength = Len(strFullName)
    intPosn = intLength
    Do While Mid(strFullName, intPosn, 1) <> "\"
        intPosn = intPosn - 1
    Loop
    strPathName = Left(strFullName, intPosn)
    strLogName = Right(strFullName, intLength - intPosn)
    
    'set 'save' folder to be same as log file
    ChangeFileOpenDirectory strPathName
    
    intLength = Len(strLogName)
    intExtnPosn = intLength - 3
    
    If Mid(strLogName, intExtnPosn, 1) = "." Then
        strDocName = Left(strLogName, intExtnPosn - 1)
    Else
        strDocName = strLogName
    End If
    
    strDocName = strDocName & ".doc"
End Sub
Sub AdjustCache(intSize, ByRef datLogDates(), ByRef datLogTimes(), ByRef blnUps())
    ReDim datLogDates(intSize)
    ReDim datLogTimes(intSize)
    ReDim blnUps(intSize)
End Sub
Sub SetupDoc(ByRef strDocName)
    Documents.Add DocumentType:=wdNewBlankDocument
    
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientLandscape
        .TopMargin = CentimetersToPoints(3.17)
        .BottomMargin = CentimetersToPoints(3.17)
        .LeftMargin = CentimetersToPoints(1.02)
        .RightMargin = CentimetersToPoints(1.27)
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(1.27)
        .FooterDistance = CentimetersToPoints(1.27)
        .PageWidth = CentimetersToPoints(29.69)
        .PageHeight = CentimetersToPoints(21)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .GutterPos = wdGutterPosLeft
    End With

    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10

    'set footer
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or _
        ActiveWindow.ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    NormalTemplate.AutoTextEntries("Filename").Insert Selection.Range
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    SaveDoc strDocName
End Sub
Sub CreateTable(intWeeksPerPage, intDaysPerWeek, datStartDateMon)
    Const intHoursPerDay = 24

    Dim intHourNo
    Dim strHdr
    Dim intWeekNo
    Dim datDate
    Dim intDayNo
    
    ActiveDocument.Tables.Add Range:=Selection.Range, _
        NumRows:=1 + (intWeeksPerPage * 7), _
        NumColumns:=2 + intHoursPerDay, _
        DefaultTableBehavior:=wdWord9TableBehavior, _
        AutoFitBehavior:=wdAutoFitFixed
    
    Selection.Tables(1).Columns.PreferredWidth = CentimetersToPoints(1.02)
    Selection.Tables(1).Select
    Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    
    Selection.MoveRight wdCell, 3
    
    For intHourNo = 0 To intHoursPerDay - 1
        If intHourNo < 10 Then
            strHdr = "0"
        Else
            strHdr = ""
        End If
        strHdr = strHdr & LTrim(Str(intHourNo)) 'allow for leading space reserved for sign!
        Selection.TypeText strHdr
        Selection.MoveRight wdCell
    Next
    
    datDate = datStartDateMon
    For intWeekNo = 1 To intWeeksPerPage
        For intDayNo = 1 To intDaysPerWeek
            Selection.TypeText Left(Format(datDate, "dddd"), 3)
            Selection.MoveRight wdCell
            Selection.TypeText Format(datDate, "dd/mm/yy")
            Selection.MoveDown wdLine, 1
            Selection.MoveLeft wdCharacter, 1
            datDate = DateSerial(Format(datDate, "yyyy"), Format(datDate, "mm"), Format(datDate, "dd") + 1)
        Next
    Next
    
End Sub
Function blnNextLogEntry( _
    ByRef strLogName, _
    ByRef strDocName, _
    intStatusFieldNo, _
    ByRef intCacheTop, _
    ByRef intCacheIndex, _
    intMaxCache, _
    ByRef datLogDates(), _
    ByRef datLogDate, _
    ByRef datLogTimes(), _
    ByRef datLogTime, _
    ByRef blnUps(), _
    ByRef blnUp)
    
    Dim strLine
    Dim strStatus
    Dim blnEof
    Dim blnCacheFull
    
    If intCacheIndex >= intCacheTop Then
        'reload cache
        intCacheIndex = 0
        intCacheTop = 0
    
        'get next entry from log
        Windows(strLogName).Activate
        
        Do
            On Error Resume Next
            Selection.Next(Unit:=wdParagraph, Count:=1).Select
            blnEof = (Err.Number = 91)
            On Error GoTo 0
            
            If blnEof Then
                blnNextLogEntry = False
            Else
                strLine = Selection.Text
                'remove any trailing crlf chars
                If Right(strLine, 2) = vbCrLf Then strLine = Left(strLine, Len(strLine) - 2)
            
                strStatus = UCase(Trim(strCut(strLine, ",", intStatusFieldNo, intStatusFieldNo)))
                
                If (strStatus = "UP") Or (strStatus = "DOWN") Then
                    'valid line, so append to cache
                    intCacheTop = intCacheTop + 1
                    blnUps(intCacheTop) = (strStatus = "UP")
                    datLogDates(intCacheTop) = Trim(strCut(strLine, ",", 1, 1))
                    datLogTimes(intCacheTop) = Trim(strCut(strLine, ",", 2, 2))
                    blnCacheFull = (intCacheTop >= intMaxCache)
                End If
            End If
        Loop Until (blnEof Or blnCacheFull)
        
        Windows(strDocName).Activate
    End If
    
    If intCacheTop = 0 Then
        blnNextLogEntry = False
    Else
        intCacheIndex = intCacheIndex + 1
        datLogDate = datLogDates(intCacheIndex)
        datLogTime = datLogTimes(intCacheIndex)
        blnUp = blnUps(intCacheIndex)
        blnNextLogEntry = True
    End If
End Function
Sub ProcessLog(ByRef strLogName, ByRef strDocName, intWeeksPerPage, intDaysPerWeek)
    Const intMaxCache = 10000
    Const sngLeftX = 104.8
    Const sngTopY = 115.8
    Const sngCellWidth = 28.9
    Const sngCellHeight = 12
    Const sngPollX = 1 '0.5
    Dim sngX
    Dim sngY
    
    Dim datLogDates()
    Dim datLogTimes()
    Dim blnUps()

    Dim intCacheTop
    Dim intCacheIndex
    Dim datLogDate
    Dim datLogTime
    Dim blnUp
    
    Dim strLine
    Dim intFieldNo
    Dim strField
    Dim intStatusFieldNo
    Dim datPageStart
    Dim datPageEnd
    Dim intDaysFromStart
    Dim intMinsFromStart
    
    AdjustCache intMaxCache, datLogDates(), datLogTimes(), blnUps()
    intCacheIndex = 0
    intCacheTop = 0
    
    Windows(strLogName).Activate
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=1, Name:=""
    
    'decode header to locate status field number
    Selection.Next(Unit:=wdParagraph, Count:=1).Select
    Selection.Previous(Unit:=wdParagraph, Count:=1).Select
    strLine = Selection.Text
    
    intStatusFieldNo = 0
    For intFieldNo = 3 To 99
        strField = UCase(Trim(strCut(strLine, ",", intFieldNo, intFieldNo)))
        If strField = "STATUS" Then
            intStatusFieldNo = intFieldNo
            intFieldNo = 99     'break
        End If
    Next
    
    If intStatusFieldNo = 0 Then
        MsgBox "Missing header in log file; unable to analyse", vbCritical + vbOKOnly
    Else
        Windows(strDocName).Activate
        datPageEnd = 0
        
        Do While blnNextLogEntry( _
            strLogName, _
            strDocName, _
            intStatusFieldNo, _
            intCacheTop, _
            intCacheIndex, _
            intMaxCache, _
            datLogDates(), _
            datLogDate, _
            datLogTimes(), _
            datLogTime, _
            blnUps(), _
            blnUp)
            
            If DateDiff("d", datLogDate, datPageEnd) <= 0 Then
                'start page on Monday boundary
                datPageStart = datLogDate
                Do While Format(datPageStart, "dddd") <> "Monday"
                    datPageStart = DateSerial(Format(datPageStart, "yyyy"), Format(datPageStart, "mm"), Format(datPageStart, "dd") - 1)
                Loop
                
                If datPageEnd <> 0 Then
                    'insert page break after the first page
                    'Selection.Collapse
                    Selection.Tables(1).Select
                    Selection.Collapse wdCollapseEnd
                    Selection.InsertBreak Type:=wdPageBreak
                Else
                    Selection.TypeParagraph
                End If
    
                CreateTable intWeeksPerPage, intDaysPerWeek, datPageStart
                datPageEnd = DateSerial(Format(datPageStart, "yyyy"), Format(datPageStart, "mm"), Format(datPageStart, "dd") + (intWeeksPerPage * intDaysPerWeek))
            End If
            
            'plot status within table on page
            intDaysFromStart = DateDiff("d", datPageStart, datLogDate)
            sngY = sngTopY + (intDaysFromStart * sngCellHeight) + ((sngCellHeight / 2) - 2)
            
            intMinsFromStart = DateDiff("n", "00:00:00", datLogTime)
            sngX = sngLeftX + (intMinsFromStart * (sngCellWidth / 60))
            
            ActiveDocument.Shapes.AddLine(sngX, sngY, sngX + sngPollX, sngY).Select
            With Selection.ShapeRange.Line
                .Weight = 3#
                .Style = msoLineSingle
                If blnUp Then
                    .ForeColor = vbGreen
                Else
                    .ForeColor = vbRed
                End If
            End With
        Loop
    End If
    
    Selection.Collapse
    AdjustCache 0, datLogDates(), datLogTimes(), blnUps()
End Sub
Sub SaveDoc(ByRef strDocName)
    ActiveDocument.SaveAs FileName:=strDocName, _
        FileFormat:=wdFormatDocument, _
        LockComments:=False, _
        Password:="", _
        AddToRecentFiles:=True, _
        WritePassword:="", _
        ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, _
        SaveFormsData:=False, _
        SaveAsAOCELetter:=False
End Sub

Function strCut(strIn, strSepChar, intStartFieldNo, intEndFieldNo)
'based on unix 'cut' command, e.g.
' "abc-c-def", "-", 2, 3 returns "c-def"
' "/abc/d/ef", "/", 2, 2 returns "abc"

Dim strOut
Dim intField
Dim lngInPosn
Dim strChar
  
    strOut = ""
    intField = 1
    lngInPosn = 1
    
    Do While (lngInPosn <= Len(strIn))
      strChar = Mid(strIn, lngInPosn, 1)
    
      If ((intField >= intStartFieldNo) And _
          (intField <= intEndFieldNo)) Then
        strOut = strOut + strChar
      End If
      
      If ((strChar = strSepChar) Or _
         ((strSepChar = " ") And _
          ((strChar = " ") Or (strChar = vbTab)))) Then
        intField = intField + 1
        If (intField > intEndFieldNo) Then Exit Do
    
        'skip multiple whitespaces
        Do
          lngInPosn = lngInPosn + 1
          strChar = Mid(strIn, lngInPosn, 1)
        Loop Until Not _
          ((lngInPosn <= Len(strIn)) And _
           ((strSepChar = " ") And _
            ((strChar = " ") Or (strChar = vbTab))))
      Else
        lngInPosn = lngInPosn + 1
      End If
      
    Loop
    
    'remove trailing separator char
    strChar = Right(strOut, 1)
    If ((strChar = strSepChar) Or _
        ((strSepChar = " ") And _
         ((strChar = " ") Or (strChar = vbTab)))) Then _
      strOut = Left(strOut, Len(strOut) - 1)
      
    strCut = strOut
End Function