BDG Scenario 3

Build (Form8.frm)

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Build 
   Caption         =   "Building Project: "
   ClientHeight    =   1425
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   1425
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin MSComDlg.CommonDialog Dialogs1 
      Left            =   4080
      Top             =   960
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Cancel"
      Height          =   375
      Left            =   1440
      TabIndex        =   0
      Top             =   960
      Width           =   1695
   End
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   600
      Width           =   4455
      _ExtentX        =   7858
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.Label lblFilename 
      Height          =   255
      Left            =   120
      TabIndex        =   3
      Top             =   360
      Width           =   4455
   End
   Begin VB.Label Label1 
      Caption         =   "Building HTML from XML and Lingo: "
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   4455
   End
End
Attribute VB_Name = "Build"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const N_MAX_PROGRESS = 200

Public m_bKill As Boolean           ' True, if dialog was canceled
Public m_buildInfo As BuildListItem ' Current build project

Private m_xmlLingo As MSXML.DOMDocument

Private Sub Form_Load()
   ProgressBar1.Max = N_MAX_PROGRESS
End Sub

Private Sub Form_Activate()
   Dim xelem As MSXML.IXMLDOMElement
   
   On Error GoTo CleanUp
   
   ' Load specified lingo file
   Set m_xmlLingo = New MSXML.DOMDocument
   m_xmlLingo.async = False
   m_xmlLingo.preserveWhiteSpace = True
   m_bKill = Not m_xmlLingo.Load(m_buildInfo.LingoFile)
   If m_bKill Then
      ParseError m_xmlLingo.ParseError
      GoTo CleanUp
   End If
   
   Me.Caption = Me.Caption & m_buildInfo.name
   Call Build

CleanUp:
   If m_bKill Then UpdateUser "Build canceled."
   Set m_xmlLingo = Nothing
   Unload Me
End Sub

Private Sub Tick()
   Static Progress As Integer
   Progress = Progress + 1
   ProgressBar1.value = (Progress Mod N_MAX_PROGRESS)
   DoEvents
End Sub

Private Sub Build()
   Dim fso As New Scripting.FileSystemObject
   Dim dir As Scripting.Folder
   Dim file As Scripting.file
   Dim xmlDoc As MSXML.DOMDocument
   
   ' Add trailing backslash on paths, if not present
   If Right(m_buildInfo.SourceDir, 1) <> "\" Then
      m_buildInfo.SourceDir = m_buildInfo.SourceDir & "\"
   End If
   If Right(m_buildInfo.DestinationDir, 1) <> "\" Then
      m_buildInfo.DestinationDir = m_buildInfo.DestinationDir & "\"
   End If
   
   ' Set lingo file to lower-case, for comparison purpose
   m_buildInfo.LingoFile = LCase(m_buildInfo.LingoFile)
   
   Set dir = fso.GetFolder(m_buildInfo.SourceDir)
   For Each file In dir.Files
      ' Only build from files with .XML extension
      If LCase(Right(file.name, 4)) = ".xml" Then
         ' Make sure to skip the lingo file, if it exists
         If LCase(file.name) <> m_buildInfo.LingoFile Then
            lblFilename.Caption = file.path
            Set xmlDoc = New MSXML.DOMDocument
            xmlDoc.async = False
            xmlDoc.preserveWhiteSpace = True
            m_bKill = Not xmlDoc.Load(file.path)
            If m_bKill Then
               ParseError xmlDoc.ParseError
               Exit For
            Else
               Call GetLingoValues(xmlDoc.documentElement)
               Call SaveDoc(xmlDoc, file.name)
            End If
            Set xmlDoc = Nothing
         End If
      End If
   Next file
End Sub

Private Sub SaveDoc(xmlDoc As MSXML.DOMDocument, file As String)
   Dim x&
   
   x = InStrRev(file, ".")
   If x > 0 Then
      file = Left(file, x) & "htm"
   Else
      file = file & ".htm"
   End If
   file = "file://" & m_buildInfo.DestinationDir & file
   
ResumeSave:
   On Error GoTo SaveFailed
   xmlDoc.save file
   Exit Sub

SaveFailed:
   MsgBox Err.Description & " (" & Hex(Err.Number) & ")", vbCritical, "Cannot Save Build Results"
   On Error GoTo SaveCanceled
   Dialogs1.CancelError = True
   Dialogs1.DialogTitle = "Save HTML Document"
   Dialogs1.Filename = Mid(file, 8) ' remove "file://" part
   Dialogs1.Filter = "HTML Files (*.htm,*.html)|*.htm;*.html|XML Files (*.xml)|*.xml|All Files (*.*)|*.*"
   Dialogs1.Flags = cdlOFNOverwritePrompt + cdlOFNPathMustExist + cdlOFNNoReadOnlyReturn
   Dialogs1.DefaultExt = "*.htm"
   Dialogs1.ShowSave
   file = Dialogs1.Filename
   Resume ResumeSave
   
SaveCanceled:
   Resume Next
End Sub

Private Sub GetLingoValues(elem As Object)
   Dim Count&
   
   ' Show progress...
   Call Tick
   
   If (elem.nodeTypeString = "element") Then
      'Debug.Print elem.nodeName
      If elem.Attributes.Length > 0 Then
         Call CopyAttributes(elem)
      End If
      For Count = 0 To elem.childNodes.Length - 1
         'Calling Recursively
         Call GetLingoValues(elem.childNodes(Count))
      Next
   End If
End Sub
  
Private Sub CopyAttributes(copyToNode As Object)
   Dim attrib As Object, Id As String
   Dim copyFromNode As MSXML.IXMLDOMNode
   
   Id = Lid(copyToNode)
   If Id <> "" Then
      Set copyFromNode = getLingoTag(UCase(copyToNode.tagName), Id)
      If Not copyFromNode Is Nothing Then
         For Each attrib In copyFromNode.Attributes
            If attrib.nodeName <> g_Options.LingoIDAttrib Then
               If attrib.nodeName = "placement" Then
                  ' BUG: should be placement sensitive
                  copyToNode.text = copyFromNode.text
               Else
                  copyToNode.setAttribute attrib.nodeName, attrib.nodeValue
               End If
            End If
         Next
      End If
   End If
End Sub

Private Function getLingoTag(ByVal name As String, Id As String) As MSXML.IXMLDOMNode
   Dim xnode As MSXML.IXMLDOMNode
   Dim xelem As MSXML.IXMLDOMElement
   Dim nodeName As String
   
   On Error GoTo ErrHandler
   
   ' First attempt: find node by LID value
   Set xelem = m_xmlLingo.nodeFromID(Id)
   If xelem Is Nothing Then
      ' If not found: find element by traversal, DO NOT create if not found
      Set xnode = m_xmlLingo.documentElement.selectSingleNode("//" & name & "S")
      If Not xnode Is Nothing Then
         nodeName = "./" & name & "[@" & g_Options.LingoIDAttrib & "='" & Id & "']"
         Set xelem = xnode.selectSingleNode(nodeName)
      End If
   End If
   Set getLingoTag = xelem
   Exit Function
ErrHandler:
   ParseError m_xmlLingo.ParseError
   MsgBox "FAIL: " & Err.Description & " (" & Hex(Err.Number) & ")", vbCritical
End Function

Private Function Lid(ByRef elem As Object) As String
   On Error Resume Next
   Lid = elem.getAttribute(g_Options.LingoIDAttrib)
End Function