'
' ZULU WEBSITE ASSEMBLER
'
' Copyright (C) 2000, Peter Maerki und Hans Maerki
'
' This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version.
' This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details.
' You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'

Option Explicit
Dim mFso As New Scripting.FileSystemObject
Dim xmlFile As Scripting.TextStream

Const cSheetColumnKeyword = 2
Const cSheetColumnTag = 3
Const cSheetColumnFirstEntry = 4
Const cSheetMaxRows = 100

Const gErrNumberGeneral = vbObjectError + 512
Const gUndefined = "undefined"
Const gExcelXmlDumpVersion = "v1.0.1"
Dim gPostprocess As String
Dim gErrorLog As String

'******* REGISTRY begin
' Registry value type definitions
Const REG_NONE As Long = 0
Const REG_SZ As Long = 1
Const REG_EXPAND_SZ As Long = 2
Const REG_BINARY As Long = 3
Const REG_DWORD As Long = 4
Const REG_LINK As Long = 6
Const REG_MULTI_SZ As Long = 7
Const REG_RESOURCE_LIST As Long = 8 ' Registry section definitions
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002

' Registry API functions used in this module (there are more of them)
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'******* REGISTRY end

'***************** Code Start ******************
'http://www.mvps.org/access/api/api0004.htm
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Terry Kreft
Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&

Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadID As Long
End Type

Private Declare Function WaitForSingleObject Lib "kernel32" ( _
    ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
   
Private Declare Function CreateProcessA Lib "kernel32" ( _
    ByVal lpApplicationName As Long, ByVal lpCommandLine As String, _
    ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
    lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
    ' ByVal lpCurrentDirectory As String should be LONG!!!

Private Declare Function CloseHandle Lib "kernel32" (ByVal _
    hObject As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long

Public Function ShellWait(Pathname As String, CurrentDirectory As String, Optional WindowStyle As Long) As Long
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    Dim ret As Long
    
    ' Initialize the STARTUPINFO structure:
    With start
        .cb = Len(start)
        If Not IsMissing(WindowStyle) Then
            .dwFlags = STARTF_USESHOWWINDOW
            .wShowWindow = WindowStyle
        End If
    End With
    ' Start the shelled application:
    ret& = CreateProcessA(0&, Pathname, 0&, 0&, 1&, _
                    NORMAL_PRIORITY_CLASS, 0&, _
                    CurrentDirectory, start, proc)
    ' Wait for the shelled application to finish:
    ret& = WaitForSingleObject(proc.hProcess, INFINITE)
    Call GetExitCodeProcess(proc.hProcess, ret&)
    Call CloseHandle(proc.hThread)
    Call CloseHandle(proc.hProcess)
    ShellWait = ret
End Function
'***************** Code End ****************

'******* REGISTRY begin
'
' This routine allows you to get values from anywhere in the Registry, it currently
' only handles string, double word and binary values. Binary values are returned as
' hex strings.
'
' Example
' Text1.Text = ReadRegistry(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "DefaultUserName")
'
Public Function ReadRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String) As String
    Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long, sValue As String, td As Double
    On Error Resume Next
    lResult = RegOpenKey(Group, Section, lKeyValue)
    sValue = Space$(2048)
    lValueLength = Len(sValue)
    lResult = RegQueryValueEx(lKeyValue, Key, 0&, lDataTypeValue, sValue, lValueLength)
    If (lResult = 0) And (Err.Number = 0) Then
       If lDataTypeValue = REG_DWORD Then
          td = Asc(Mid$(sValue, 1, 1)) + &H100& * Asc(Mid$(sValue, 2, 1)) + &H10000 * Asc(Mid$(sValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(sValue, 4, 1)))
          sValue = Format$(td, "000")
       End If
       If lDataTypeValue = REG_BINARY Then
           ' Return a binary field as a hex string (2 chars per byte)
           Dim TStr1 As String
           Dim TStr2 As String
           Dim i As Integer
           TStr2 = ""
           For i = 1 To lValueLength
              TStr1 = Hex(Asc(Mid(sValue, i, 1)))
              If Len(TStr1) = 1 Then TStr1 = "0" & TStr1
              TStr2 = TStr2 + TStr1
           Next
           sValue = TStr2
       Else
          sValue = Left$(sValue, lValueLength - 1)
       End If
    Else
       sValue = "Not Found"
    End If
    lResult = RegCloseKey(lKeyValue)
    ReadRegistry = sValue
End Function
'******* REGISTRY end

Private Sub xmlWriteLine(strLine As String)
    xmlFile.WriteLine strLine
End Sub

Private Sub CommandButtonGenerate_Click()
    ExcelXmlDump
    StartPostprocessing
End Sub

Private Sub StartPostprocessing()
    Dim rc As Long
    ' rc = ShellWait("C:\Python22\python.exe """ & Application.ActiveWorkbook.Path & "\zulu.py""", vbNormalNoFocus)
    ' rc = ShellWait("C:\Python22\python.exe zulu.py", Application.ActiveWorkbook.Path, vbNormalNoFocus)
    Dim strPythonPath As String
    strPythonPath = ReadRegistry(HKEY_LOCAL_MACHINE, "SOFTWARE\Python\PythonCore\2.2\InstallPath", "") & "\python.exe"
    If Not mFso.FileExists(strPythonPath) Then
        MsgBox "No binary found at" & vbCrLf & strPythonPath, vbCritical
    End If
    rc = ShellWait(strPythonPath & " " & gPostprocess & " -s """ & GetXmlFilename & """", Application.ActiveWorkbook.Path, vbNormalNoFocus)
    If rc <> 0 Then
        MsgBox "Zulu failed: see " & gErrorLog, vbCritical
    End If
End Sub

Private Function GetXmlFilename() As String
    GetXmlFilename = Replace(Application.ActiveWorkbook.Name, ".xls", ".xml")
End Function

Private Sub ExcelXmlDump()
    gPostprocess = "zulu.py"
    gErrorLog = "zulu_errorlog.html"
    Dim iRow As Integer
    Set xmlFile = mFso.CreateTextFile(Application.ActiveWorkbook.Path & "\" & GetXmlFilename, True)
    xmlWriteLine "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
    xmlWriteLine "<content>"
    xmlWriteLine "  <creator>"
    xmlWriteLine "    <program>ExcelXmlDump " & gExcelXmlDumpVersion & "</program>"
    xmlWriteLine "    <date>" & Format(Now, "YYYY-MM-DD hh:mm:ss") & "</date>"
    xmlWriteLine "    <excel_filename>" & Application.ActiveWorkbook.Name & "</excel_filename>"
    xmlWriteLine "    <excel_path>" & Application.ActiveWorkbook.Path & "</excel_path>"
    xmlWriteLine "  </creator>"
    iRow = 1
    Do While iRow < Sheet1.UsedRange.Rows.Count + 50
        iRow = xmlDump(iRow) + 1
    Loop
    xmlWriteLine "</content>"
    xmlFile.Close
    Set xmlFile = Nothing
End Sub

Private Function xmlDump(iRow As Integer) As Integer
    Dim sKeyword As String
    sKeyword = Sheet1.Cells(iRow, cSheetColumnKeyword)
    If sKeyword = "" Then
        xmlDump = iRow
        Exit Function
    End If
    Select Case Right(sKeyword, 1)
        Case ":":
                xmlDumpLine iRow, Left(sKeyword, Len(sKeyword) - 1)
        Case ">":
                xmlDump = xmlDumpTable(iRow, Left(sKeyword, Len(sKeyword) - 1))
                Exit Function
        Case Else
    End Select
    xmlDump = iRow
End Function

Private Function xmlDumpTable(iFirstRow As Integer, sFirstKeyword As String) As Integer
    Dim iRow As Integer
    xmlWriteLine "  <" & xmlFixTag(sFirstKeyword) & " type=""table"">"
    For iRow = iFirstRow + 1 To Sheet1.UsedRange.Rows.Count + 50
        Dim sKeyword As String
        sKeyword = Sheet1.Cells(iRow, cSheetColumnKeyword)
        If sKeyword <> sFirstKeyword & ":" Then
            ' The end of the Table
            Exit For
        End If
        xmlDumpTableLine iFirstRow, iRow, sFirstKeyword
    Next iRow
    xmlWriteLine "  </" & xmlFixTag(sFirstKeyword) & ">"
    xmlDumpTable = iRow
End Function

Private Sub xmlDumpTableLine(iFirstRow As Integer, iRow As Integer, sFirstKeyword As String)
    Dim iColumn As Integer
    Dim sTag As String
    sTag = Sheet1.Cells(iFirstRow, cSheetColumnTag)
    xmlWriteLine "    <" & xmlFixTag(sTag) & ">"
    For iColumn = cSheetColumnFirstEntry To Sheet1.UsedRange.Columns.Count + 20
        Dim sRowLabel As String
        sRowLabel = Sheet1.Cells(iFirstRow, iColumn)
        If sRowLabel = "" Then
            Exit For
        End If
        xmlDumpTableField iRow, iColumn, sRowLabel
    Next iColumn
    xmlWriteLine "    </" & xmlFixTag(sTag) & ">"
End Sub

Private Function xmlDumpTableField(iRow As Integer, iColumn As Integer, sRowLabel As String) As Boolean
    Dim sValue As String
    sValue = Sheet1.Cells(iRow, iColumn)
    ' If sValue = "" Then
    '    Exit Function
    ' End If
    xmlWriteLine "       <" & xmlFixTag(sRowLabel) & ">" & toXML(sValue) & "</" & xmlFixTag(sRowLabel) & ">"
End Function

Private Sub xmlDumpLine(iRow As Integer, sKeyword As String)
    If Sheet1.Cells(iRow, cSheetColumnKeyword) = "Postprocess:" Then
        gPostprocess = Sheet1.Cells(iRow, cSheetColumnFirstEntry)
    End If
    If Sheet1.Cells(iRow, cSheetColumnKeyword) = "ErrorLog:" Then
        gErrorLog = Sheet1.Cells(iRow, cSheetColumnFirstEntry)
    End If
    
    xmlWriteLine "  <" & xmlFixTag(sKeyword) & ">"
    xmlDumpLineField iRow, cSheetColumnTag, "tag"
    Dim iColumn As Integer
    For iColumn = cSheetColumnFirstEntry To Sheet1.UsedRange.Columns.Count + 20
        xmlDumpLineField iRow, iColumn, Chr(iColumn - cSheetColumnFirstEntry + Asc("a"))
    Next iColumn
    xmlWriteLine "  </" & xmlFixTag(sKeyword) & ">"
End Sub

Private Sub xmlDumpLineField(iRow As Integer, iColumn As Integer, strLabel As String)
    Dim sValue As String
    sValue = Sheet1.Cells(iRow, iColumn)
    If sValue = "" Then
        Exit Sub
    End If
    xmlWriteLine "     <" & xmlFixTag(strLabel) & ">" & toXML(sValue) & "</" & xmlFixTag(strLabel) & ">"
End Sub

Private Function xmlFixTag(strTag As String) As String
    xmlFixTag = strTag
    If xmlFixTag = "" Then
        xmlFixTag = "==empty=="
    End If
    xmlFixTag = Replace(xmlFixTag, "<", "==lessthan==")
    xmlFixTag = Replace(xmlFixTag, ">", "==greaterthan==")
    xmlFixTag = Replace(xmlFixTag, " ", "==space==")
End Function

Private Function toXML(strValue As String)
    strValue = Replace(strValue, "&", "&amp;")
    strValue = Replace(strValue, "<", "&lt;")
    strValue = Replace(strValue, ">", "&gt;")
    toXML = strValue
End Function