Lingo.cls

Option Explicit

Const N_MISSINGFOLDER = &H800C0100
Const S_MISSINGFODLER = "Missing Destination Folder Name"
Const N_FOLDERNOTEXIST = &H800C0101
Const S_FOLDERNOTEXIST = "Folder doesn't exist"

Private Enum WalkDirConsts
   dwWalkDirNormal = 0
   dwWalkCurDirOnly = 1
   dwDirectoriesOnly = 2
End Enum

Private gXML As MSXML.DOMDocument
Private lXML As MSXML.DOMDocument
Private ASP As ASPTypeLibrary.Response

Public Sub Build(ByVal SourcePath As String, _
                 ByVal DestinationPath As String, _
                 Optional ByVal LingoFile As String = "lingo.xml")
   Dim oc As ObjectContext
   
   On Error GoTo ErrHandler
   
   If Not (DestinationPath = "" Or SourcePath = "") Then
      
      Set oc = GetObjectContext
      If Not oc Is Nothing Then
         Set ASP = oc("Response")
      End If
      
      'Qualify path with  '\'
      If Not Right(SourcePath, 1) = "\" Then
         SourcePath = SourcePath & "\"
      End If
      If Not Right(DestinationPath, 1) = "\" Then
         DestinationPath = DestinationPath & "\"
      End If
      'merges lingo with globalized xml template files and store
      'them into destination directory
      Call GetFiles(SourcePath, DestinationPath, LingoFile)
   Else
       Err.Raise N_MISSINGFOLDER, "Lingo.Build", S_MISSINGFODLER
   End If
   Exit Sub
  
ErrHandler:
   Err.Raise Err.number, Err.source, Err.description
End Sub

Private Sub GetFiles(ByVal sSourcePath As String, _
                     ByVal sDestination As String, _
                     ByVal sLingo As String)

   Dim WFD As WIN32_FIND_DATA
  
   Dim hFile As Long
   Dim bNext As Long
   Dim currFile As String
   Dim fileNumber As Long
   Dim fileName As String
   Dim resultString As String
  
   On Error GoTo ErrHandler
  
  'Start searching for files in the Target directory.
   hFile = FindFirstFile(sSourcePath & "*.xml", WFD)
   If (hFile = INVALID_HANDLE_VALUE) Then
      'catastrophic error
       Err.Raise Err.number, Err.source, Err.description
       Exit Sub
   End If
   
   'get each file to the new directory with *.htm extension
   If hFile Then
      Do
         currFile = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
         'change the extension from .xml to .htm
         fileName = sDestination & Left$(currFile, InStrRev(currFile, ".", -1, vbTextCompare)) & "htm"
         
         If Not FileExists(fileName) Then
           If Not ASP Is Nothing Then
            ASP.Write "Building " & currFile & "...<BR>"
           End If
           'Merges current globalized template file with Lingo Files
           Call Translate(sSourcePath & currFile, sDestination & sLingo)
           'resultString contains merged contents
           resultString = gXML.xml
           If Not (resultString = "" Or IsEmpty(resultString)) Then
                'creating an htm file using XMLDocument.save method
                Call gXML.Save(fileName)
           End If
         Else
           If Not ASP Is Nothing Then
            ASP.Write currFile & " already built. Skipping...<BR>"
           End If
         End If
         
NextFile:
         On Error GoTo ErrHandler
         'find the next file matching the initial file spec
         bNext = FindNextFile(hFile, WFD)
       Loop Until bNext = 0
   End If
   
   ASP.Write "Done..."
   'Close the search handle
   Call FindClose(hFile)
   Exit Sub
   
ErrHandler:
   Resume NextFile
End Sub

Private Function FileExists(ByVal fileName As String) As Boolean
   Dim hFile As Long
   Dim WFD As WIN32_FIND_DATA
   'gets the handle to file if it exists
   hFile = FindFirstFile(fileName, WFD)
   FileExists = hFile <> INVALID_HANDLE_VALUE
End Function

Private Sub Translate(ByVal gXMLURL As String, ByVal lXMLURL As String)
   On Error Resume Next
 
   Set gXML = CreateObject("Microsoft.XMLDOM")
   Set lXML = CreateObject("Microsoft.XMLDOM")
   
   gXML.async = False
   lXML.async = False
   
   gXML.preserveWhiteSpace = True
   lXML.preserveWhiteSpace = True
   
   lXML.Load (lXMLURL)
   If parseError(lXML) Then GoTo ErrHandler
   
   gXML.Load (gXMLURL)
   If parseError(gXML) Then GoTo ErrHandler
    
   'pass collection of Nodes that has expando property LID
   'and do merging with Lingo File
   Call GetLingoValues(gXML.selectNodes("//*[@LID]"))
   'set the character set value for particular language
   Call SetCharsetValue
   Exit Sub
   
ErrHandler:
   Err.Raise Err.number, Err.source, Err.description
End Sub

Private Sub SetCharsetValue()
   Dim charset As String
   Dim fromNode As IXMLDOMNode
   Dim toNode As IXMLDOMElement
   Dim parentNode As IXMLDOMNode
   Dim childNode As IXMLDOMElement
   Dim pi As IXMLDOMProcessingInstruction
   
   On Error GoTo ErrHandler
   
   'selects the value of charset using pattern match
   Set fromNode = lXML.selectSingleNode("//UIElement/@CHARSET")
   If fromNode Is Nothing Then
      charset = "UTF-8"
   Else
      charset = fromNode.NodeValue
   End If
   
   'locates the meta tag in XML template file
   Set toNode = gXML.selectSingleNode("//META[@http-equiv]")
   If toNode Is Nothing Then
      Set toNode = gXML.selectSingleNode("//meta[@http-equiv]")
   End If
   If Not toNode Is Nothing Then
      'appends the attribute with charset value
      toNode.setAttribute "content", "text/htm; charset=" & charset
   Else
     'locates the HEAD Node
      Set toNode = gXML.selectSingleNode("//HTML/HEAD")
      'creates new meta tag
      Set childNode = gXML.createElement("META")
      'add attributes
      childNode.setAttribute "http-equiv", "content-type"
      childNode.setAttribute "content", "text/html; charset=" & charset
      'appends to parent (HEAD) node
      toNode.appendChild childNode
   End If
   
   'use charset as encoding value for this new file
   Set pi = gXML.createProcessingInstruction("xml", _
            "version='1.0' encoding='" & charset & "'")
   Call gXML.insertBefore(pi, gXML.firstChild)
   
   Exit Sub
   
ErrHandler:
      Err.Raise "Error " & Hex(Err.number), Err.source, Err.description
End Sub

Private Function parseError(ByRef xmlDoc As MSXML.DOMDocument) As Boolean
   If xmlDoc.parseError.errorCode <> 0 Then
      Call reportError(xmlDoc.url, xmlDoc.parseError)
      parseError = True
   Else
      parseError = False
   End If
End Function
   
Private Sub reportError(ByVal where As String, ByRef perr As IXMLDOMParseError)
   Dim str As String
   str = "Error loading <B>" & where & "</B><BR>" & _
         "Reason: " & perr.reason & "<BR>" & _
         "Line: " & perr.Line & "<BR>" & _
         "Source: " & perr.srcText & "<BR>" & _
         "Line Pos.: " & perr.linepos & "<BR>"
   If Not ASP Is Nothing Then
      'returns the string to browser with error information
      ASP.Write str
   End If
End Sub
 
Private Sub GetLingoValues(ByRef colls As IXMLDOMNodeList)
   Dim item As IXMLDOMNode
   
   For Each item In colls
      If (item.nodeTypeString = "element") Then
           If item.Attributes.length > 0 Then
              'get attributes from lingo file and appends with
              'XML template file
              Call GetNodeValue(item)
           End If
      End If
   Next
End Sub
  
Private Sub GetNodeValue(ByRef elem As IXMLDOMNode)
   Dim count As Integer
   Dim copyFromNode As IXMLDOMNode
   Dim NodeValue As String
   
   On Error Resume Next
   
    For count = 0 To elem.Attributes.length - 1
    'maps the LID of template file with LID of Lingo file
      If UCase(elem.Attributes(count).nodeName) = "LID" Then
         NodeValue = elem.Attributes(count).NodeValue
         Set copyFromNode = lXML.nodeFromID(NodeValue)
         If Not copyFromNode Is Nothing Then
           Call AppendAttribs(elem, copyFromNode)
         Else
           ASP.Write "<b><i>Error : Missing LID = " & _
                     NodeValue & " in Lingo File. </i></b>.<br>"
           GoTo ErrHandler
         End If
      End If
    Next
    Exit Sub
ErrHandler:
   Err.Raise "Error No: " & Hex(Err.number), "Lingo.GetNodeValue", Err.description
End Sub
Private Sub AppendAttribs(ByRef copyToNode As IXMLDOMElement, ByRef copyFromNode As IXMLDOMNode)
    Dim count As Integer
    Dim index As Integer
    Dim childNode As IXMLDOMNode
    Dim checkNode As IXMLDOMNode
    Dim parentNode As IXMLDOMNode
   
    
    For count = 0 To copyFromNode.Attributes.length - 1
     'skips the LID attribute from lingo file
     'since its already present in XML template file
      If Not UCase(copyFromNode.Attributes(count).nodeName) = "LID" Then
        'Before appending attribute from lingo file to XML template file
        'it is decoded from unicoded string to its character value
        copyToNode.setAttribute copyFromNode.Attributes(count).nodeName, _
                   copyFromNode.Attributes(count).NodeValue
      End If
    Next
    
    If copyFromNode.hasChildNodes Then
    'In case labels have <U> tag to identify accesskey
      If copyFromNode.childNodes.length > 1 Then
         For index = 0 To copyFromNode.childNodes.length - 1
           Set checkNode = copyFromNode.childNodes(index)
           Set childNode = checkNode.cloneNode(True)
           copyToNode.appendChild childNode
         Next
      Else
         'creates textNode and appends to global XML template file
         Set childNode = gXML.createTextNode(copyFromNode.Text)
         copyToNode.appendChild childNode
      End If
    End If
End Sub


Public Function LoadMenuOptions(ByVal srcDir As String, Optional ByVal lingoFileName As String = "lingo.xml") As Collection
   Dim colls As New Collection
   On Err GoTo ErrHandler
   'look for all folders in srcDirectory having lingoFile in it
   ' and adds them to collection
   Call BrowseFolder(srcDir, lingoFileName, colls)
   'returns the collection of all folders which have lingo file present.
   Set LoadMenuOptions = colls
   Exit Function

ErrHandler:
   Err.Raise "Error " & Hex(Err.number), Err.description, Err.source
End Function

Private Sub BrowseFolder(sSrcDir As String, sSearchItem As String, ByRef colls As Collection, Optional fFlags As WalkDirConsts = dwWalkDirNormal)
  Dim SubDirCount  As Integer
  Dim TempFilename As String
  Dim count        As Integer
  Dim FileSize     As Long
  Dim SubDirs()    As String
  
  If Not Right(sSrcDir, 1) = "\" Then
      sSrcDir = sSrcDir & "\"
  End If
  
  If fFlags And dwDirectoriesOnly Then
    'Look for directory entries Only
    TempFilename = Dir$(sSrcDir & sSearchItem, vbDirectory)
    Do While (Len(TempFilename) > 0)
      'Ignore the "." and ".." directory entries
      If Left$(TempFilename, 1) <> "." Then
        If IsDirectory(sSrcDir & TempFilename) Then
          If IsNotRepeated(sSrcDir, colls) Then
            colls.Add sSrcDir
          End If
        End If
      End If
      TempFilename = Dir$
      DoEvents
    Loop
  
  Else
    'Look for non-directory entries
    TempFilename = Dir$(sSrcDir$ & sSearchItem)
    Do While (Len(TempFilename) > 0)
      If IsNotRepeated(sSrcDir, colls) Then
         colls.Add sSrcDir
      End If
      TempFilename = Dir$
      DoEvents
    Loop
  End If
  
  If (fFlags And dwWalkCurDirOnly) Then Exit Sub
  
  'Now look for sub-directories
  ReDim SubDirs(10)
  TempFilename = Dir$(sSrcDir$ + "*.*", vbDirectory)
  Do While Len(TempFilename) > 0
    If Left$(TempFilename, 1) <> "." Then
      If IsDirectory(sSrcDir & TempFilename) Then
        SubDirs(SubDirCount) = TempFilename
        SubDirCount = SubDirCount + 1
        If SubDirCount = UBound(SubDirs) Then
          ReDim Preserve SubDirs(SubDirCount + 10)
        End If
      End If
    End If
    TempFilename = Dir$
    DoEvents
  Loop
  
  'Now walk the subdirectories:

  For count = 0 To SubDirCount% - 1
    Call BrowseFolder(sSrcDir + SubDirs(count) + "\", sSearchItem, colls, fFlags)
  Next count
End Sub

Private Function IsDirectory(sFile As String) As Boolean
  Dim nAttr As Integer
  Dim nErr  As Integer

  On Error Resume Next
  nAttr = GetAttr(sFile)
  nErr = Err.number
  
  On Error GoTo 0
  IsDirectory = (nErr = 0) And ((nAttr And vbDirectory) = vbDirectory)
End Function

Private Function StripFromRight(ByVal strItem As String) As String
   Dim pos As Integer
   On Error GoTo ErrHandler
   If Right(strItem, 1) = "\" Then
      strItem = Left(strItem, Len(strItem) - 1)
   End If
   pos = InStrRev(strItem, "\", -1, vbTextCompare)
   If pos Then StripFromRight = Right(strItem, Len(strItem) - pos)
   Exit Function

ErrHandler:
   Err.Raise "Error " & Hex(Err.number), Err.description, Err.source
End Function

Private Function IsNotRepeated(ByRef srcItem As String, ByRef colls As Collection) As Boolean
   Dim count As Integer
   Dim flag As Boolean
   
   On Error GoTo ErrHandler
   flag = True
   'Gets the folder name  from full app path
   srcItem = StripFromRight(srcItem)
   If colls.count > 0 Then
      For count = 1 To colls.count
        If StrComp(CStr(colls.item(count)), srcItem, vbTextCompare) = 0 Then
          'item already  present in collection
          flag = False
          Exit For
        End If
      Next
   End If
   IsNotRepeated = flag
   Exit Function
  
ErrHandler:
   Err.Raise "Error " & Hex(Err.number), Err.description, Err.source
End Function

Public Function SniffLang(ByVal strLang As String, ByVal appPath As String, ByVal LingoFile As String) As String
   Dim bigArray() As String
   Dim smallArray() As String
   Dim tempString As String
   Dim languages As New Collection
   Dim colls As New Collection
   Dim count As Integer
   Dim index As Integer
   Dim folderExists As Boolean
   Dim oc As ObjectContext
   Dim ASPApplication As ASPTypeLibrary.Application
   
   On Error GoTo ErrHandler
   
   bigArray = Split(strLang, ";", , vbTextCompare)
   
   For count = LBound(bigArray) To UBound(bigArray)
       smallArray = Split(bigArray(count), ",", , vbTextCompare)
       For index = LBound(smallArray) To UBound(smallArray)
       tempString = smallArray(index)
         If Not IsNumeric(Right(tempString, Len(tempString) - InStrRev(tempString, "=", -1, vbTextCompare))) Then
            languages.Add tempString, tempString
         End If
       Next
   Next
   
   For count = 1 To languages.count
       'Tests the existence of folder with lingo file matching
       'with the name of language settings of IE
       folderExists = ExactMatch(appPath, languages.item(count))
       If folderExists Then
         SniffLang = languages.item(count)
         Exit For
       End If
   Next
   
   If Not folderExists Then
     Call BrowseFolder(appPath, LingoFile, colls, dwWalkDirNormal)
     For count = 1 To languages.count
       folderExists = RoughMatch(colls, languages.item(count))
       If folderExists Then
         SniffLang = languages.item(count)
         Exit For
       End If
     Next
   End If
   
   If Not folderExists Then
      Set oc = GetObjectContext
      Set ASPApplication = oc("Application")
      SniffLang = CStr(ASPApplication.StaticObjects("DefaultLanguage"))
   End If
   Exit Function
ErrHandler:
   SniffLang = "en-us"
End Function

Private Function ExactMatch(ByVal appPath As String, ByVal strLang As String) As Boolean
   Dim colls As New Collection
   Call BrowseFolder(appPath, strLang, colls, dwDirectoriesOnly)
   ExactMatch = colls.count
End Function

Private Function RoughMatch(ByVal colls As Collection, ByVal strLang As String) As Boolean
   Dim count As Integer
   For count = 1 To colls.count
     If CStr(colls.item(count)) Like Left(strLang, 2) & "*" Then
       RoughMatch = True
       Exit Function
     End If
   Next
   RoughMatch = False
End Function