' Merit Badge Counselor code
' by Paul Ventura
' all rights reserved
'------------------
'key routines
dim lastrow
Dim xoffset, yoffset, bDrag, sBackgroundColor, objDrag, dragAction, objLast,bDirty,objProp
dim lastx, lasty, noteID, currentnote, bLoaded,wDefault,hDefault, conntemp
dim yStart,xStart,hStart,wStart
dim strFind,strReplace,intFindCount,iStartScrollPosition,lastelm,pLast
'----------------
Function Checkerror(text)
    if err.number<>0 then
        msgbox "Error at " & text & err.description
     err.clear 
    end if
end function
'----------------
Function Checkkey()
 keycode = window.event.keycode
 if keycode = 13 then
  search
 end if
end function
'----------------
Function clearfilter()
    dim sFilter,ctl
    for each ctl in trFilter.all.tags("INPUT")
        ctl.value = ""
    next
    txtSearch.value = ""
    search
end function
'----------------
Function getfilter()
    dim sFilter,ctl
    for each ctl in trFilter.all.tags("INPUT")
        v = ctl.value
        if len(v)>0 then
            fld = ctl.datafld
            fldtrans = "translate(" & fld & ",'ABCDEFGHIJKLMNOPQRSTUVWXYZ','abcdefghijklmnopqrstuvwxyz')"
            sFilter = sFilter & "[contains(" & fldtrans & ",'" & lcase(v) & "')]"
        end if
    next
    getfilter = sFilter
end function
'----------------
Function ExportXML()

' this will read an xml table and export it as a spreadsheet table.
'
    dim s,s1,sh,cr,numrecs,stepsize,k,x,tab
    set x = xmlfilter
    cr = chr(13) & chr(10)
    tab = chr(9)
' get the field names
    set nodx = x.selectsinglenode("/*/*")
    s = s & "<table style='table-layout:fixed'>" & cr
    s = s & "<tr style='background-color:silver'>"
    for each child in nodx.childnodes
        s = s & "<td>" & child.nodename & "</td>"
    next
    s = s & "</tr>" & cr

' get the number of records
    set nodelist = x.selectnodes("/*/*")
    numrecs = nodelist.length


' set the largest step size to the square root of the data size.
    stepsize = int(sqr(numrecs)+1)

' now get all of the rows within the data.
    k = 0
    s1 = "<tr>"
    for each nodx in nodelist
        if k >=stepsize then

        ' add the substring to the main string
            s = s & s1

        ' reset sub string
            s1 = "<tr>"
        end if

    ' add all the fields for this record
        for each child in nodx.childnodes
            s1 = s1 & "<td>" & child.text & "</td>"
        next
        s1 = s1 & "</tr>" & cr
        k = k + 1
    next

' add the final substring
    s = s & s1

' close up the table
    s = s & "</table>"

' create a header about source of export data.
    sh = "Data source: " & window.location & "<br/>"
    sh = sh & "Date:  " & Now() & "<br/>"
    sh = sh & "Filter:  " & txtSearch.value & " | " & getfilter & "<br/>"
    sh = sh & "Records:  " & numrecs & "<br/>"
    
    frmExport.data.value =  sh & s
    frmExport.submit
 ' clean up memory
  s = ""
end function
'---------------
Sub exportXML2()
    dim tab, cr, r, c,s,row
    set tbl = tblData
    n = tbl.datapagesize
    tbl.datapagesize = 2000

' initialize variables
    tab = chr(9)
    cr = chr(13) & chr(10)
    S = ""

' save the xml as a tab delimited spreadsheet file.
    for r = 1 to tblData.rows.length-1
        set row = tblData.rows(r)
        for c = 0 to row.cells.length-1
            s = s & row.cells(c).innertext & tab
        next
        s = s & cr
    next

' now save the file
    path = "c:\MBCounselors.xls"
    path = inputbox("Enter file path to save ",,path )
    if path = "" then exit sub

' restore the table to the normal size
    tbl.datapagesize=n
    writefile path, s
end sub
'----------------
Function GetFolder()
    on error resume next

' return only the folder portion of the path
    dim p
    path = getpath
    p = instrRev(path,"\")
    getfolder = mid(Path,1,p)
    checkerror "Function GetFolder()"
end function
'-------------
Function Getsize(txt)
' This function returns a numeric value for a pixel dimension.
  dim p
  p = instr(txt,"px")

' validate input
  if p = 0 then exit function

' return size
  getsize = cint(mid(txt,1,p-1))
end function
'------------------
Function Writefile(path,text)
    on error resume next
    Const ForReading = 1, ForWriting = 2
    Dim fso, f

' Open the text file for writing
    Set fso = CreateObject("Scripting.FileSystemObject")
    if not (fso.FileExists(path)) then

    '  msgbox "Creating new file"
        fso.CreateTextFile path 'Create a file
    end if
    Set f = fso.OpenTextFile(path, ForWriting, True)

' write the text to the file
    f.write text

' Close the file.
    f.close
    set f = nothing
    window.status = "File saved: " & path & " at " & now

' msgbox "File saved: " & path & " at " & now
    'checkerror "Function Writefile(path,text)"
end function
'---------------
sub filter()
    search
end sub
'-------------
Sub SaveData(x)
    on error resume next
    dim data

' get the datasource for the xml file
    filename = x.src

' if the path contains a colon, assume it is full.
    if instr(filename,":")=0 and instr(filename,"\\")=0 then
        path = getfolder() & filename
    else
        path = filename
    end if
    if Len(x.xml) < 200 then
        msgbox "Can't Save file it is too small."
        exit sub
    else

    ' msgbox "Length of data = " & len(x.xml)
    end if
    writefile path,x.xml
    msgbox  path & " Saved at " & formatdt(now(),1)

'  checkerror "Sub SaveData(x)"
end sub
'-------------

Sub Search()
' search for the text in any of the fields.
    upper = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    lower = lcase(upper)
    v = txtSearch.value
    fldtrans = "translate(.,'" & upper & "','" & lower & "')"
    sfilter = getfilter
' if the advanced filter row is not disiplayed, then filter records based on search box.

   if trFilter.style.display="none" then
     query = "//MBC[contains(" & fldtrans & ",'" & lcase(v) & "')]" 
    else
' if the advanced filter row is displayed, use that to filter the records instead.
     query = "//MBC" & sFilter
' this is the combined filter for both. - disabled.
  '   query = "//MBC[contains(" & fldtrans & ",'" & lcase(v) & "')]" & sFilter

   end if

    xMBC.setproperty "SelectionLanguage", "XPath"
' create a nodelist of all the records that match.
    set nodelist = xMBC.selectnodes(query)

' loop through the nodelist and add this records to the filtered list.
    set x = xmlfilter

' clear the filtered recordset
    x.selectnodes("//MBC").removeall

' add in the nodes from the master set.
    for each nodx in nodelist

    ' copy the node to the filter
        set newnode = nodx.clonenode(true)

    ' add it to the root
        x.documentelement.appendchild newnode
    next
    if nodelist.length=0 then
        msgbox "No Records found. "
    end if

' set the datasource of the table to the filtered recordset
    tblData.datasrc = "#xmlfilter"
    showrecnum
    showpagenum
end sub
'----------------
Sub SelectRow()
    on error resume next
    dim elm, tbl,k

' highlight the current row.
    set elm = window.event.srcelement
    if instr("SPAN,TD",elm.tagname)=0 then exit sub
    do while elm.tagname<>"TR"
        set elm = elm.parentelement
    loop
    elm.style.backgroundcolor = "yellow"
    set tbl = elm
    do while tbl.tagname<>"TABLE"
        set tbl = tbl.parentelement
    loop

' set the record number for the table
    tbl.setattribute "recnum", elm.recordnumber
    on error resume next
    n = elm.recordnumber
    showrecnum

'  msgbox "n=" & n & " xml=" & xTasks.selectsinglenode("//task["& n & "]").xml
' set the background color of last row = blank.
' chack to make sure object exists before trying to set the property.
    if not(isempty(lastrow)) then
        lastrow.style.backgroundcolor = ""
    end if
    set lastrow = elm
    checkerror "Sub Selectrow()"
end sub
'----------------
sub showmail()
' abort default behavior
  window.event.returnvalue = false
  window.event.cancelbubble= true
  set elm = window.event.srcelement
  h = elm.innertext
  window.status = "Send email to " & h
end sub
'------------------
Sub showme()
    on error resume next
    window.status = window.event.srcelement.outerhtml
end sub
'----------------
Sub showpagenum()
    dim page,pages,n,tbl,dsc,x,datapagesize,pagesize
    on error resume next

' get the record of the selected row
    set tbl = tblData
    set x = xmlfilter
    datapagesize = tbl.datapagesize
    numrecs = x.selectnodes("//MBC").length
    if datapagesize="" or numrecs=0 then
        txtPage.value = 1
        txtPages.value = 1
    else
        pagesize = cint(datapagesize)
        r = tbl.rows.length-2
        n = tbl.rows(r).recordnumber
        page = int((n+pagesize-1)/pagesize)
        pages = int((numrecs+pagesize-1)/pagesize)
        txtpage.value = page
        txtpages.value = pages
    end if
end sub
'----------------
Sub showrecnum()
    on error resume next
    set tbl = tblData
    set x = xmlfilter
    numrecs= x.selectnodes("//MBC").length
    spMessage.innertext = numrecs & " records found."

' get the record of the selected row
    n = tbl.getattribute("recnum")
    'txtRecord.value = n
   ' txtRecords.value =numrecs

'  checkerror "Sub showrecnum()"
end sub
'----------------
Sub Sortcol()
    dim ci, elm, nodc, nodr
    exit sub
' this will sort the currently bound recordset by the selected column.
    set elm = window.event.srcelement
    if elm.tagname <>"TD" then exit sub

' get the cell number.
    ci = elm.cellindex

' go look up in the config table what the nth field name is.
    set ctl = tblData.rows(0).cells(ci).children(0)
    fld = ctl.datafld

     set x = xmlfilter
    set nodelist = x.selectnodes("//MBC")
    for r = 0 to nodelist.length-1

    ' get the current and next values
        c = x.selectsinglenode("//MBC[" & r & "]/" & fld).text
        n = x.selectsinglenode("//MBC[" & r+1 & "]/" & fld ).text

     ' if the current one is > next one, then swap them
        if ucase(c) > ucase(n) then
  
        ' start at the current position and bubble up to the start.
            for j = r to 0 step -1

            ' get the current and next values
                c = x.selectsinglenode("//MBC[" & j & "]/" & fld ).text
                n = x.selectsinglenode("//MBC[" & j+1  & "]/" & fld ).text
             ' if the current one is > next one, then swap them
                if ucase(c)>ucase(n) then

                       set nodc = x.selectsinglenode("//MBC[" & j & "]")
                    set nodn = x.selectsinglenode("//MBC[" & j+1 & "]")
                    set par = nodc.parentnode
                    par.insertbefore nodn, nodc
                else

                ' continue checking DOWN the list.
                    exit for
                end if
            next
        end if

    ' end of the sort up.
    next
    msgbox "List is now sorted by col. " & fld
end sub
'----------------
sub tablechange()

' this will catch the change if the table has changed.
    if tblData.readystate="complete" then
        showrecnum
        showpagenum
    end if
end sub 
'----------------
Sub toggle(obj)
    on error resume next
    if obj.style.display = "" then
        obj.style.display = "none"
    else
        obj.style.display =""
      '  obj.scrollintoview
    end if
end sub
'----------------
Sub Toggleme()
' this will toggle the parent Div
    dim elm, par,id
    set elm = window.event.srcelement
    set par = elm.parentelement

' loop up until you find a div.
    do while par.tagname <>"DIV"
        set par = par.parentelement
    loop
       toggle par
end sub
'----------------
Sub Viewdata(x)
    on error resume next

' go navigate to the xml data source
    h = x.src

'    window.navigate h
' open a new window
    window.open h,"_Top"
    checkerror "Sub viewdata(x)"
end sub
'----------------
Sub window_onload()

' attach the showme function to the body tag
    document.body.attachevent "onmouseover",getref("showme")

' set the focus to the search box.
    txtSearch.focus
    txtSearch.select
'Display the last modified date of the file.
url = "MBC.xml"
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
xmlhttp.open "HEAD", URL, False
xmlhttp.send 
sDate = xmlhttp.getResponseHeader("Last-Modified")
 dt1 = convertGMTdate(sDate)
spModified.innertext = "Updated: " & dt1 

end sub
Function ConvertGMTDate(GMT)
' returns a date from a GMT date string
' ex Sat, 31 Oct 2009 20:40:56 GMT" 
dim ar,sDate
' parse the date string on the spaces
 ar = split(GMT," ")
' make familiar dd-mmm-yyyy format
 sDate = ar(1) & "-" & ar(2) & "-" & ar(3)
' convert to date
 ConvertGMTDate= cdate(sdate)
end function
'---------------
Function ConvertGMTTime(GMT)
' returns a date from a GMT date string
' ex Sat, 31 Oct 2009 20:40:56 GMT" 
dim ar
' parse the date string on the spaces
 ar = split(gmt," ")
' make familiar dd-mmm-yyyy format
 sDate = ar(1) & "-" & ar(2) & "-" & ar(3)
' convert to date
 ConvertGMTTime= cdate(ar(4))
end function