Hubris

Becks · Post by **Becks** » 18 Apr 2011, 15:38

The following piece of code generates an error - what is the error and which statement(s) cause(s) it?

I've included a test worksheet
It does what it is supposed to do - generate an html page ready for a website but there is a side-effect. To run it, pass the name of the sheet to the procedure.
(Because it's in the puzzles section, I discovered what the error was - eventually.)

Code: Select all


Sub Prepare_html_file3(swksPBs As String)
Dim wksPBs          As Worksheet
Dim iNoSwimmers     As Integer
Dim sTitle          As String
Dim iDistance       As Integer
Dim sStroke         As String
Dim sFilename       As String
Dim fID             As Integer
Dim iCount          As Integer
Dim dTime           As Double
Dim tMeetDate       As Date
Dim iAge            As Integer
Dim sh0
Dim sh1
Dim sh2

Const TD            As String = "            <td>"
'change as desired
Const OUT_DIR       As String = "c:\Users\THSC\Documents\website\Updates\"

    sh0 = Array("<!DOCTYPE html PUBLIC ""-//W3C//DTD HTML 4.01 Frameset//EN"" ", _
                "   ""http://www.w3.org/TR/html4/frameset.dtd"">", _
                "<html>", _
                "", _
                "<head>")
                
    sh1 = Array("", "    <script type=""text/javascript"" src=""../Code/swimTimes2.js""></script>", _
                "", _
                "    <meta http-equiv=""content-type""", _
                "        content=""text/html;charset=utf-8"" />", _
                "    <meta http-equiv=""Content-Style-Type"" content=""text/css"" />", _
                "    <link rel=stylesheet type=""text/css"" href=""../thsc.css"" />", _
                "<script type='text/javascript' src='../Code/xthf1-xlib.js'></script>", _
                "<script type='text/javascript'>", _
                "xAddEventListener(window, 'load',", _
                "  function() {", _
                "    new xTableHeaderFixed('xthf-thsc', window, true);", _
                "  }, false", _
                ");", _
                "</script>", _
                "</head>", "", _
                "<body  link=""#FFE902"" text=""#FFE902"" vlink=""#FFE902"" alink=""#FFFFFF"" onLoad=""LookForCookie(3, 1)"" >", _
                "<div id='topLinkCon'><a name='topofpg'>&nbsp;</a></div>", _
                "    <table cellspacing=""0"" cellpadding=""0"" width=""100%"" class=""xthf-thsc"" >", _
                "    <caption>")
                
''                "<body  link=""#FFE902"" text=""#FFE902"" vlink=""#FFE902"" alink=""#FFFFFF""  onload=""LookForCookie(3)"" >", _
''                "    <table cellspacing=""0"" cellpadding=""5"" width=""100%"">", _
''                "        <tr height=""50"">") ', _
''                "        <td  background=""../graphics/Top.png""class=""pbHeader"">&nbsp;")
    'Tuart Hill Swimming Club - 50m Backstroke PBs&nbsp; (04/07/2009)
    sh2 = Array("        </caption>", _
                "    <thead>", _
                "        <tr >", _
                "            <th>Time</th>", _
                "            <th>Meet</th>", _
                "            <th>Date</th>", _
                "            <th>Name</th>", _
                "            <th>Gender</th>", _
                "            <th>Age</th>", _
                "        </tr>", _
                "    </thead>", _
                "    <tfoot>", _
                "        <tr><td colspan=""6"" height=""5""></td></tr>", _
                "    </tfoot>", _
                "    <tbody id=""swimTimes"" >")
    
    Application.ScreenUpdating = False

    Set wksPBs = ThisWorkbook.Worksheets(swksPBs)
    
    With wksPBs.Range("A1")
        iCount = InStr(.Value, "(")
        sTitle = Trim(Left(.Value, iCount - 1))
        tMeetDate = DateValue(Mid(.Value, iCount + 1, 10))
        
        iCount = InStr(.Value, "- ") + 2
        iDistance = Val(Mid(.Value, iCount))
        iCount = InStr(iCount, .Value, "m ", vbTextCompare)
        sStroke = Mid(.Value, iCount + 2)
        iCount = InStr(sStroke, " ")
        sStroke = Left(sStroke, iCount - 1)
        If sStroke = "Individual" Then sStroke = "IM"
        
        sFilename = OUT_DIR & sStroke & iDistance & "m.html"
    End With

    'delete previous copy
    On Error Resume Next
    Kill sFilename
    On Error GoTo 0
    
    'publish it
    fID = FreeFile()
    
    Open sFilename For Output As #fID
    For iCount = LBound(sh0) To UBound(sh0)
        Print #fID, sh0(iCount)
    Next iCount
    Print #fID, "<title>"; sTitle; "</title>"

    For iCount = LBound(sh1) To UBound(sh1)
        Print #fID, sh1(iCount)
    Next iCount
   
    Print #fID, wksPBs.Range("A1").Value; "<br />&nbsp;"
    
    For iCount = LBound(sh2) To UBound(sh2)
        Print #fID, sh2(iCount)
    Next iCount
    
    
    With wksPBs.Range("A4")
        'count num swimmers
        iNoSwimmers = Application.WorksheetFunction.Max(.Offset(20000, 2).End(xlUp).Row, .Offset(20000, 0).End(xlUp).Row) - 3
        
        'sort formula
        .Offset(0, 5).Resize(iNoSwimmers, 1).FormulaR1C1 = "=IF(RC[-5]=0, 3600, IF(RC[-5]>1, RC[-5], RC[-5] * 24 * 60 * 60))"
        .Offset(0, 6).Resize(iNoSwimmers, 1).FormulaR1C1 = "=IF(RC[-6]="""", 3600, IF(RC[-4]="""", R[-1]C[-1]+0.001, RC[-1]))"
        .Offset(0, 5).Resize(iNoSwimmers, 2).Copy
        .Offset(0, 5).PasteSpecial xlPasteValues
                
        'sort it
        .Resize(iNoSwimmers, 7).Sort .Offset(0, 6), xlAscending, .Offset(0, 6), , xlAscending
        'count num swimmers with times
        iNoSwimmers = .Offset(1000, 0).End(xlUp).Row - 3
        
        For iCount = 0 To iNoSwimmers - 1
            
            'row colour
            Print #fID, "        <tr>"
            
            'swimmer's time
            Print #fID, TD;
            Print #fID, Format_time(.Offset(iCount, 0).Value);
            Print #fID, "</td>"
            
            'meet & date
            iDistance = InStr(1, .Offset(iCount, 1).Value, "(")
            iAge = InStr(iDistance, .Offset(iCount, 1).Value, ")")
                Print #fID, TD; Left(.Offset(iCount, 1).Value, iDistance - 1); "</td>"
                Print #fID, TD; Mid(.Offset(iCount, 1).Value, iDistance + 1, iAge - iDistance - 1); "</td>"
            If Len(.Offset(iCount, 2).Value) > 0 Then
                'name
                Print #fID, TD; .Offset(iCount, 2).Value; "</td>"
            
                'sex
                Print #fID, TD;
                If .Offset(iCount, 4) = "M" Then
                    Print #fID, "Male";
                Else
                    Print #fID, "Female";
                End If
                Print #fID, "</td>"
            
                'age
                With .Offset(iCount, 3)
                    iAge = Year(tMeetDate) - Year(.Value)
                    If DateSerial(Year(tMeetDate), Month(tMeetDate), Day(tMeetDate)) < DateSerial(Year(tMeetDate), Month(.Value), Day(.Value)) Then
                        iAge = iAge - 1
                    End If
                End With
                Print #fID, TD; iAge; "</td>"
            Else
                Print #fID, TD; " </td><td> </td><td> </td>"
            End If
            
            Print #fID, "        </tr>"
            'End If
        Next iCount
    End With
    
   
    'final bits
    Print #fID, "        </tbody>"
    Print #fID, "    </table>"
    Print #fID, "    <p class=""THFooter"">If two times are listed for a swimmer, then the second time is best time at Tuart Hill Pool <br><br>"
    Print #fID, "    </p >"
    Print #fID, "</body>"
    Print #fID, "</html>"
    
    Close #fID
    
    'clear sort times
    With wksPBs
        .Activate
        .Columns(6).Clear
        .Columns(7).Clear
        .Range("A1").Select
    End With
    Application.ScreenUpdating = True
    
    Set wksPBs = Nothing
End Sub

Jezza · Post by **Jezza** » 28 Apr 2011, 15:42

I can't even get this sub to work.....maybe it is just me but can you set it up so that we can as it is not very clear what we are trying to do here

Post by **HansV** » 28 Apr 2011, 15:54

The function Format_Time is not defined within the code that you posted. If I provide a simple version, your code runs without error on the sheet in your sample workbook, producing a complete web page that is hard to read because of the yellow text on a white background...

Becks · Post by **Becks** » 10 May 2011, 13:36

Apologies for the yellow font, the css sheet on the website provides all the corrections. The error isn't in the web page - there is a "residual" effect for the workbook itself.

Here is the missing function

Code: Select all

Function Format_time(ByVal dValue As Double) As String
Dim iMins   As Integer

    If dValue < 1 Then
        dValue = dValue * 24 * 60 * 60
    End If
        
    If dValue > 60 Then
        iMins = Application.WorksheetFunction.RoundDown(dValue / 60, 0)
        Format_time = Trim("" & iMins) & ":" & Format(dValue - iMins * 60, "00.00")
    Else
        Format_time = Format(dValue, "00.00")
    End If

End Function

Hubris was thinking I could write error-free code (or be able to debug it easily), and, it seems, being able to post a problem without errors as well.

Kevin

Eileen's Lounge

Hubris

Hubris

Re: Hubris

Re: Hubris

Re: Hubris