Attribute VB_Name = "VBACore"
'
' VBACore - primary entry point (see export_Click) and its direct subroutines
'
Option Explicit

Private Sub Station_XMLize(xmlobjs As Variant, stnid As String, laloh As Variant)
  Dim xdoc As MSXML2.DOMDocument, xleaf As IXMLDOMNode
  Set xdoc = xmlobjs(0)
  Set xleaf = xmlobjs(1)
  Dim xitem As IXMLDOMNode
  Set xitem = xleaf.appendChild(xdoc.createElement("item"))
  xitem.appendChild(xdoc.createElement("stnid")).Text = stnid
  xitem.appendChild(xdoc.createElement("table")).Text = laloh(0)
  If laloh(1) <> "" Then
    xitem.appendChild(xdoc.createElement("lat")).Text = laloh(1)
  End If
  If laloh(2) <> "" Then
    xitem.appendChild(xdoc.createElement("lon")).Text = laloh(2)
  End If
  If laloh(3) <> "" Then
    xitem.appendChild(xdoc.createElement("h")).Text = laloh(3)
  End If
  If laloh(4) <> "" Then
    xitem.appendChild(xdoc.createElement("name")).Text = laloh(4)
  Else
    xitem.appendChild(xdoc.createElement("name")).Text = "(UNKNOWN)"
    xitem.Attributes.setNamedItem(xdoc.createAttribute("error")).Text = "unresolved"
  End If
End Sub

Private Sub StationList_Breakdown(log As Long, xmlobjs As Variant, _
  ByVal sVal As String, dsname As String _
  )
  Dim sppos As Long
  sVal = sVal & " "
  While True
    sppos = InStr(sVal, " ")
    If (sppos = 1) Then
      ' skip leading space
      sVal = Mid$(sVal, 2)
    ElseIf (sppos > 1) Then
      Dim s As String
      s = Left$(sVal, sppos - 1)
      sVal = Mid$(sVal, sppos + 1)
      Dim laloh As Variant
      If (stringPattern(s, "#####$")) Then
        laloh = StationLookup(s, "VOLA")
      ElseIf (stringPattern(s, "@@@@$")) Then
        laloh = StationLookup(s, "CCCC")
      Else
        Print #log, "Warning " & dsname & ": malformatted station <" & s & ">"
        GoTo SkipThisStation
      End If
      If (laloh(1) = "") Then
        Print #log, "Warning " & dsname & ": station " & s _
          & " not found in table " & laloh(0)
      End If
      Call Station_XMLize(xmlobjs, s, laloh)
    Else
      GoTo SkipThisCellAtAll
    End If
SkipThisStation:
  Wend
SkipThisCellAtAll:
End Sub

Private Sub ConvertRow(log As Long, sh As Worksheet, irow As Long, ncols As Long, _
  shContact As Worksheet)
  Dim fnam As String, dsname As String, sCCCC As String, sRTH As String
  Dim icol As Long
  '
  sRTH = Trim(sh.Cells(irow, 1))
  sCCCC = Trim(sh.Cells(irow, 7))
  dsname = Trim(sh.Cells(irow, 6).Value) + sCCCC
  If Not (stringPattern(dsname, "@@@@##@@@@")) Then
    Print #log, "Error: dataset <" & dsname & "> is not in expected pattern."
  End If
  fnam = ThisWorkbook.path + "\md-" + dsname + "-raw.xml"
  If (getopt("SkipCCCC") = sCCCC) Then
    Print #log, "Info: " & dsname & ": skipped due to option SkipCCCC=" & sCCCC
    Exit Sub
  End If
  '
  ' open xml
  '
  Dim xdoc As New MSXML2.DOMDocument
  Dim xroot As IXMLDOMNode
  xdoc.appendChild xdoc.createProcessingInstruction("xml", "version='1.0'")
  Set xroot = xdoc.appendChild(xdoc.createNode(NODE_ELEMENT, "bmd", ""))
  Dim datetime As Variant
  datetime = UTC_Now()
  Calendar = vbCalGreg
  Dim sDatetime As String
  sDatetime = Format(datetime, "yyyy-mm-dd") + "T" + Format(datetime, "hh:nn:ss") + "Z"
  xroot.appendChild(xdoc.createElement("dateStamp")).Text = sDatetime
  '
  ' metadata for the dataset
  '
  Dim xeds As IXMLDOMNode
  Set xeds = xroot.appendChild(xdoc.createElement("dataset"))
  For icol = 1 To ncols
    Dim xleaf As IXMLDOMNode
    Dim skey As String, sVal As String
    sVal = Trim(sh.Cells(irow, icol).Value)
    If sVal <> "" Then
      skey = Trim(sh.Cells(1, icol).Value)
      Set xleaf = xeds.appendChild(xdoc.createElement("p"))
'     xleaf.Attributes.setNamedItem(xdoc.createAttribute("k")).Text = sKey
      xleaf.appendChild(xdoc.createElement("k")).Text = skey
      xleaf.appendChild(xdoc.createElement("v")).Text = sVal
      If (skey = "Stations") Then
        Call StationList_Breakdown(log, Array(xdoc, xleaf), sVal, dsname)
      End If
    End If
  Next icol
  '
  ' metadata for contact
  '
  Dim jrow As Long, mcols As Long, jcol As Long
  mcols = shContact.Cells(1, shContact.Columns.Count).End(xlToLeft).Column
  Dim cTypes As Variant, ictype As Long
  cTypes = Array("MetadataContact", "DataContact", "RTH")
  For ictype = 0 To 2
    Dim sKeyB As String, sKeyA As String
    If cTypes(ictype) = "RTH" Then
      sKeyB = sRTH
    Else
      sKeyB = sCCCC
    End If
    sKeyA = cTypes(ictype)
    jrow = Search_iRow2(shContact, 1, sKeyA, 2, sKeyB, 2)
    If (jrow < 0) Then
      Print #log, "Error " & dsname & ": " & sKeyA & "=" & sKeyB & " not found in table CONTACT"
      Exit Sub
    Else
      Dim xecont As IXMLDOMNode
      Set xecont = xroot.appendChild(xdoc.createElement("contact"))
      xecont.Attributes.setNamedItem(xdoc.createAttribute("role")).Text _
        = shContact.Cells(jrow, 1).Value
      For jcol = 2 To mcols
        Dim xleaf2 As IXMLDOMNode
        Dim skey2 As String, sVal2 As String
        sVal2 = Trim(shContact.Cells(jrow, jcol).Value)
        If sVal2 <> "" Then
          skey2 = Trim(shContact.Cells(1, jcol).Value)
          Set xleaf2 = xecont.appendChild(xdoc.createElement("p"))
          xleaf2.appendChild(xdoc.createElement("k")).Text = skey2
          xleaf2.appendChild(xdoc.createElement("v")).Text = sVal2
        End If
      Next jcol
    End If
  Next ictype
    
  Dim optSaveRawXML As Boolean
  optSaveRawXML = (LCase$(getopt("SaveRawXML")) = "yes")
  If optSaveRawXML Then
    xdoc.Save fnam
  End If

  Dim xslt As New MSXML2.DOMDocument
  xslt.async = False
  xslt.loadXML sXSLraw2gmd()
  If (xslt.parseError.errorCode <> 0) Then
    Print #log, "Error loading stylesheet", xslt.parseError.line, xslt.parseError.srcText
    Exit Sub
  End If
  Dim xresult As New MSXML2.DOMDocument
  On Error GoTo XSLT_ERR
  xdoc.transformNodeToObject xslt, xresult
  On Error GoTo 0
  
  If optSaveRawXML Then
    Dim fso As New FileSystemObject
    fso.DeleteFile fnam, True
  End If
  
  Dim rfnam As String
  rfnam = ThisWorkbook.path + "\md-" + dsname + "-gmd.xml"
  xresult.Save rfnam
  DeleteBOM rfnam
  Print #log, "ok """ & rfnam & """ created"
  Exit Sub

XSLT_ERR:
  Print #log, "Error " & ERR.Number & ": at " & ERR.Source
  Print #log, "# " & ERR.Description
  If optSaveRawXML Then
    Print #log, "Info: intermediate file """ & fnam & """ may be helpful"
  End If

End Sub


Private Sub ConvertAllRows(log As Long, sh As Worksheet, shContact As Worksheet)
  Dim nrows As Long, irow As Long, ncols As Long
  Dim cellstr As String
  nrows = sh.Cells(sh.Rows.Count, 6).End(xlUp).row
  ncols = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
  For irow = 2 To nrows
    Call ConvertRow(log, sh, irow, ncols, shContact)
    cellstr = sh.Cells(irow, 6).Value
  Next irow
End Sub


Private Sub ConvertAllDataSheets()
  Dim path As String
  Dim nsh As Long, ish As Long, log As Long
  Dim cellstr As String
  Dim sh As Worksheet, shContact As Worksheet
  log = FreeFile
  path = ThisWorkbook.path & "\" & Left$(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & ".log"
  Open path For Output As #log
  Set shContact = ThisWorkbook.Sheets("CONTACT")
  nsh = ThisWorkbook.Sheets.Count
  For ish = 1 To nsh
    Set sh = ThisWorkbook.Sheets(ish)
    If starts_with(sh.Name, "data.") Then
      Call ConvertAllRows(log, sh, shContact)
    End If
  Next ish
  Close #log
  Call Shell("notepad " & path, vbNormalFocus)
End Sub

' --- MAIN ENTRY POINT ASSIGNED TO BUTTON ON THE SHEET ---
Public Sub export_Click()
Attribute export_Click.VB_Description = "converts all data sheets into metadata XML"
Attribute export_Click.VB_ProcData.VB_Invoke_Func = "C\n14"
  Call ConvertAllDataSheets
End Sub

Sub DeleteBOM(fileName As String)
  Dim objFSO As FileSystemObject
  Dim objTS As TextStream
  Dim strBuff As String
  Set objFSO = New FileSystemObject
  Set objTS = objFSO.OpenTextFile(fileName, , , True)
  strBuff = objTS.ReadAll
  objTS.Close
  Set objTS = objFSO.OpenTextFile(fileName, ForWriting, True)
  objTS.WriteLine strBuff
  objTS.Close
End Sub