Convert (Form4.frm)

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Convert 
   Caption         =   "Please Wait"
   ClientHeight    =   1185
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form4"
   ScaleHeight     =   1185
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "Cancel"
      Height          =   375
      Left            =   1440
      TabIndex        =   1
      Top             =   720
      Width           =   1695
   End
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   360
      Width           =   4455
      _ExtentX        =   7858
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.Label Label1 
      Caption         =   "Traversing HTMLDOM element tree..."
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   4455
   End
End
Attribute VB_Name = "Convert"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const N_MAX_PROGRESS = 200
Const N_INDENT_INCREMENT = 3

Public m_rootElem As Object   ' Set to root of HTMLDOM before invoking
Public m_strHTML As String    ' Converted HTML/XML text
Public m_bKill As Boolean     ' True, if dialog was canceled

Private m_sCloseTag As String
Private m_bCompleteURL As Boolean
Private m_xmlDoc As New MSXML.DOMDocument

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

Private Sub Form_Activate()
   Dim xelem As MSXML.IXMLDOMElement
   m_strHTML = ""
   m_bCompleteURL = g_Options.CompleteURL
   m_sCloseTag = IIf(g_Options.ConvertToXML, " />", ">")
   If g_Options.UseLingoFile Then
      m_xmlDoc.async = False
      m_xmlDoc.preserveWhiteSpace = True
      m_bKill = Not m_xmlDoc.Load(g_Options.LingoFilePath)
      If m_bKill Then
         ' If file not found, then create a default version
         If m_xmlDoc.ParseError.errorCode = &H800C0006 Then
            Set xelem = m_xmlDoc.createElement("UIElement")
            ' BUG: Should change values according to source language
            xelem.setAttribute "CHARSET", "ISO-8859-1"
            xelem.setAttribute "CODEPAGE", "1252"
            xelem.setAttribute "xmlns", "x-schema:LingoSchema.xml"
            Set m_xmlDoc.documentElement = xelem
            m_bKill = False
         ' Otherwise, report error and allow fail
         Else
            ParseError m_xmlDoc.ParseError
         End If
      End If
   Else
      m_bKill = False
   End If
   TraverseTree m_rootElem
   If m_bKill Then
      UpdateUser "Conversion canceled."
   ElseIf g_Options.UseLingoFile Then
      On Error GoTo SaveFailed ' will fail if read-only
      m_xmlDoc.save g_Options.LingoFilePath
   End If
   Unload Me
   Exit Sub
   
SaveFailed:
   MsgBox Err.Description & " (" & Hex(Err.Number) & ")", vbCritical, "Cannot Save Lingo Updates"
   Resume Next
End Sub

' Cancel
Private Sub Command1_Click()
   m_bKill = True
End Sub

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

'==== Methods for HTMLDOM traversal

Private Sub TraverseTree(ByRef elem As Object, Optional ByVal indents As Integer = 0)
   Dim Child As Object, sText As String, bIsAlways As Boolean
   
   Debug.Assert elem.nodeType = 1
   
   If m_bKill Then Exit Sub
   
   Tick   ' show progress

   On Error Resume Next
   
   ' Skip elements that are only ending tags
   If Left(elem.tagName, 1) = "/" Then Exit Sub
   
   ' Special handling for HTML comments (no begin/end tags)
   If elem.tagName = "!" Then
      m_strHTML = m_strHTML & Space(indents) & elem.innerHTML
   
   ' For elements with children: use afterBegin and beforeEnd text, recursion
   ElseIf elem.canHaveChildren And elem.tagName <> "LABEL" Then
      
      m_strHTML = m_strHTML & Space(indents) & "<" & elem.tagName
      Call showAttributes(elem)
      
      sText = elem.getAdjacentText("afterBegin") ' may cause error...
      
      If elem.children.Length > 0 Then
         
         m_strHTML = m_strHTML & ">"
         If sText <> "" And g_Options.UseLingoFile Then
            Call addLingoText(elem, sText, "afterBegin")
         Else
            m_strHTML = m_strHTML & sText
         End If
         m_strHTML = m_strHTML & vbCrLf
         
         ' Recursive call for each child element
         For Each Child In elem.children
            Call TraverseTree(Child, indents + N_INDENT_INCREMENT)
         Next
         
         sText = ""
         sText = elem.getAdjacentText("beforeEnd") ' may cause error...
         If sText <> "" And g_Options.UseLingoFile Then
            Call addLingoText(elem, sText, "beforeEnd")
         Else
            m_strHTML = m_strHTML & sText
         End If
         m_strHTML = m_strHTML & Space(indents) & "</" & elem.tagName & ">"
      
      ' Child-less: use afterBegin as complete text
      Else
         
         bIsAlways = IIf(Not g_Options.ConvertToXML Or g_Options.UseAlwaysTags, _
                         g_Options.IsAlwaysTag(elem.tagName), False)
      
         If sText <> "" Or bIsAlways Then
            m_strHTML = m_strHTML & ">"
            If g_Options.UseLingoFile Then
               Call addLingoText(elem, sText, "innerText")
            Else
               m_strHTML = m_strHTML & sText
            End If
            m_strHTML = m_strHTML & "</" & elem.tagName & ">"
         Else
            m_strHTML = m_strHTML & m_sCloseTag
         End If
      End If
   
   ' No children allowed: use beforeBegin and innerHTML as text
   Else
      sText = Trim(elem.getAdjacentText("beforeBegin")) ' may cause error...
      If sText <> "" And g_Options.UseLingoFile Then
         Call addLingoText(elem, sText, "beforeBegin")
      Else
         m_strHTML = m_strHTML & sText
      End If
      
      sText = elem.innerHTML
      ' If innerHTML exists, we may need to force assignment of LID
      If sText <> "" And g_Options.UseLingoFile Then Call Lid(elem)
      
      m_strHTML = m_strHTML & Space(indents) & "<" & elem.tagName
      Call showAttributes(elem)
      
      bIsAlways = IIf(Not g_Options.ConvertToXML Or g_Options.UseAlwaysTags, _
                      g_Options.IsAlwaysTag(elem.tagName), False)
      
      
      If sText <> "" Or bIsAlways Then
         m_strHTML = m_strHTML & ">"
         If g_Options.UseLingoFile Then
            Call addLingoText(elem, sText, "innerHTML")
         Else
            m_strHTML = m_strHTML & sText
         End If
         m_strHTML = m_strHTML & "</" & elem.tagName & ">"
      Else
         m_strHTML = m_strHTML & m_sCloseTag
      End If
   End If
   
   ' Newline
   m_strHTML = m_strHTML & vbCrLf
End Sub

Private Sub showAttributes(ByRef elem As Object)
   Dim attrib As Object, bAdded As Boolean
   For Each attrib In elem.Attributes
      If attrib.specified Then
         bAdded = False
         If g_Options.UseLingoFile Then
            If g_Options.IsLingoTag(attrib.nodeName) Then
               bAdded = addLingoAttribute(elem, attrib.nodeName, attrib.nodeValue)
            End If
         End If
         If Not bAdded Then
            Select Case attrib.nodeName
            Case "bgColor", "color", "text", "link", "aLink", "vLink":
               Call addAttribute(attrib.nodeName, ColorVal(attrib.nodeValue))
            Case "height", "width", "border", "cellPadding", "cellSpacing", "SIZE", _
                 "leftMargin", "rightMargin", "topMargin", "bottomMargin":
                Call addAttribute(attrib.nodeName, SizeVal(attrib.nodeValue))
            'Case "size":   ' used by FONT tags
               'Call addAttribute(attrib.nodeName, FontSizeVal(attrib.nodeValue))
            Case "src", "href", "action":
               Call addAttribute(attrib.nodeName, URLVal(attrib.nodeValue, m_bCompleteURL))
            Case Else:
               Call addAttribute(attrib.nodeName, attrib.nodeValue)
            End Select
         End If
      End If
   Next
   ' some important INPUT fields don't seem to be included in collection
   If elem.tagName = "INPUT" Then
      If elem.value <> "" Then
         ' NOTE: Always try to add VALUE to lingo attributes
         If g_Options.UseLingoFile And LCase(elem.Type) <> "hidden" Then
            bAdded = addLingoAttribute(elem, "value", elem.value)
         Else
            bAdded = False
         End If
         If Not bAdded Then Call addAttribute("value", elem.value)
      End If
      If elem.Size <> 0 Then
         Call addAttribute("size", elem.Size)
      End If
   ElseIf elem.tagName = "FONT" Then
     If elem.Size <> 0 Then
         Call addAttribute("size", elem.Size)
     End If
   End If
   ' STYLE text is not included in Attribute collection either
   If elem.Style.cssText <> "" Then
      Call addAttribute("style", elem.Style.cssText)
   End If
   ' Now parse through the custom (expando) attributes
   Call showCustomAttrib(elem)
End Sub

' CUSTOM ATTRIBUTES aren't found in the Attributes collection,
' but they can be accessed if you know what you're looking for...
Private Sub showCustomAttrib(ByRef elem As Object)
   Dim value As String, bAdded As Boolean
   Dim i As Long, attrib As String
   On Error Resume Next
   For i = 0 To g_Options.CustomAttributeCount  ' 0 = Lingo ID attrib
      attrib = g_Options.GetCustomAttribute(i)
      value = elem.getAttribute(attrib, 1)  ' 1 = case-sensitive
      If Err Or IsNull(value) Then
         ' attribute doesn't exist
         Err.Clear
      Else
         bAdded = False
         If g_Options.UseLingoFile Then
            If g_Options.IsLingoTag(attrib) Then
               bAdded = addLingoAttribute(elem, attrib, value)
            End If
         End If
         If Not bAdded Then Call addAttribute(attrib, value)
      End If
   Next
End Sub

Private Sub addAttribute(ByRef name As String, ByRef value As String)
   Dim q As String
   If InStr(value, """") Then q = "'" Else q = """"
   m_strHTML = m_strHTML & " " & name & "=" & q & value & q
End Sub

Private Function addLingoAttribute(ByRef elem As Object, ByRef name As String, ByRef value As String)
   Dim xelem As MSXML.IXMLDOMElement
   
   If Not g_Options.UseLingoFile Then Exit Function
   
   Set xelem = GetLingoTag(elem.tagName, Lid(elem))
   If Not xelem Is Nothing Then
      ' set the element attribute
      xelem.setAttribute name, value
      If Not g_Options.StripLingoText Then
         Call addAttribute(name, "LINGO--" & value & "--LINGO")
      End If
      addLingoAttribute = True
   Else
      ' just add the attribute
      addLingoAttribute = False
   End If
End Function

Private Sub addLingoText(ByRef elem As Object, ByRef text As String, ByVal placement As String)
   Dim xelem As MSXML.IXMLDOMElement
   Dim nRet As Integer, prevPlacement As String
   
   If Not g_Options.UseLingoFile Then Exit Sub
   If Trim(text) = "" Then Exit Sub
   
   Set xelem = GetLingoTag(elem.tagName, Lid(elem))
   If Not xelem Is Nothing Then
      If xelem.text <> "" And xelem.text <> text Then
         prevPlacement = xelem.getAttribute("placement")
         nRet = MsgBox("Overwriting " & prevPlacement & " text of " & Lid(elem) & ":" & vbCrLf & _
                xelem.text & vbCrLf & vbCrLf & _
                "with the following " & placement & " text:" & vbCrLf & _
                text & vbCrLf & vbCrLf & _
                "OK to continue?", vbQuestion + vbYesNo, "Overwrite Lingo Text")
      Else
         nRet = vbYes
      End If
      
      If nRet = vbYes Then
         ' set the element text
         xelem.text = text
         xelem.setAttribute "placement", placement
         If Not g_Options.StripLingoText Then
            m_strHTML = m_strHTML & "LINGO--" & text & "--LINGO"
         End If
      End If
   Else
      ' just output the text
      m_strHTML = m_strHTML & text
   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
   
   ' We must have an ID to locate the right lingo tag
   If Id = "" Then
      Set GetLingoTag = Nothing
      Exit Function
   End If
   
   On Error GoTo ErrHandler
   
   ' First attempt: find node by LID value
   Set xelem = m_xmlDoc.nodeFromID(Id)
   If xelem Is Nothing Then
      ' If not found: find element by traversal, create elements if necessary
      Set xnode = m_xmlDoc.documentElement.selectSingleNode("//" & name & "S")
      If xnode Is Nothing Then
         Set xnode = m_xmlDoc.createElement(name & "S")
         Set xnode = m_xmlDoc.documentElement.appendChild(xnode)
      End If
      nodeName = "./" & name & "[@" & g_Options.LingoIDAttrib & "='" & Id & "']"
      Set xelem = xnode.selectSingleNode(nodeName)
      If xelem Is Nothing Then
         Set xelem = m_xmlDoc.createElement(name)
         xelem.setAttribute g_Options.LingoIDAttrib, Id
         xnode.appendChild xelem
      End If
   End If
   Set GetLingoTag = xelem
   Exit Function
   
ErrHandler:
   ParseError m_xmlDoc.ParseError
   MsgBox "FAIL: " & Err.Description & " (" & Hex(Err.Number) & ")", vbCritical
End Function

Private Function Lid(ByRef elem As Object) As String
   Dim newLID As Variant ' must be Variant for setAttribute call
   On Error Resume Next
   ' use predefined LID, if available
   newLID = elem.getAttribute(g_Options.LingoIDAttrib, 1)
   If IsNull(newLID) And g_Options.AssignLIDs Then
      newLID = Left(elem.tagName, 3) & Format((Rnd * 9999) + 1, "0000")
      ' Debug.Print elem.uniqueID & " setting LID: " & newLID
      Call elem.setAttribute(g_Options.LingoIDAttrib, newLID, True) ' 1 = respect case
   End If
   Lid = newLID & ""
End Function