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