Attribute VB_Name = "cnv_RegToExeA"
Option Explicit
Option Base 0

' Copyright (C) 2001-2006 Jan Vorel

' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.

' This program 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 General Public License for more details.

' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

' This is a shared modul, class modul, usercontrol or form. It is also
' published under the GNU General Public License.
' This special Version is optimized for QuickPlayer

' If you have any questions, suggestions or bug reports about this product,
' contact me: info@ctuser.net; Do not contact me about general B.A.S.I.C.
' language or A.P.I. issues


Public Function ConvertRegestryA_ReadFile(ByVal ExeFileName As String, Optional ByVal FileID As Long = -1&) As String
  Dim xChar1 As String
  Dim xLong1 As Long
  
  If FileID = -1& Or FileID = 0& Then FileID = FreeFile
  
  If Left(ExeFileName, 1&) & Right(ExeFileName, 1&) = Chr(34&) & Chr(34&) And Not Len(ExeFileName) = 1& Then
    ExeFileName = Mid(ExeFileName, 2&, Len(ExeFileName) - 2&)
    End If
  
  On Error GoTo Er1
  Open ExeFileName For Input As FileID
  Close FileID
  Open ExeFileName For Binary Access Read Lock Write As FileID
  ConvertRegestryA_ReadFile = String(LOF(1), vbNullChar)
  Get FileID, , ConvertRegestryA_ReadFile
  Close FileID
  
  If Left(ConvertRegestryA_ReadFile, 2&) = Chr(255&) & Chr(254&) Then
    If Not UnUnicode(ConvertRegestryA_ReadFile) Then
      ConvertRegestryA_ReadFile = vbNullChar
      Exit Function
      End If
    DoEvents
    End If
    
  xLong1 = InStr(ConvertRegestryA_ReadFile, vbCr)
  If xLong1 = 0& Then
    ConvertRegestryA_ReadFile = Chr(1&)
    Else
    xChar1 = UCase(Trim(Left(ConvertRegestryA_ReadFile, xLong1 - 1&)))
    'ConvertRegestryA_ReadFile = Mid(ConvertRegestryA_ReadFile, xLong1 + 1&) & vbCr
    If (Left(xChar1, 8&) = "REGEDIT4" Or Left(xChar1, 36&) = "WINDOWS REGISTRY EDITOR VERSION 5.00") And UCase(Right(ExeFileName, 4&)) = ".REG" Then
      'ConvertRegestryA_ReadFile = Replace(Replace(Mid(ConvertRegestryA_ReadFile, xLong1 + 1&) & vbCr, vbLf, ""), vbTab, "")
      ConvertRegestryA_ReadFile = Replace(ConvertRegestryA_ReadFile, vbTab, "")
      DoEvents
      If Trim(Replace(ConvertRegestryA_ReadFile, vbCrLf, "")) = "" Then
        ConvertRegestryA_ReadFile = Chr(1&) '"" ' vbNullChar
        'Else
        'SuccessFull
        End If
      DoEvents
      Else
      ConvertRegestryA_ReadFile = ""
      End If
    End If
  
Rs1:
  On Error GoTo 0
  Close FileID
  Exit Function
  
Er1:
  ConvertRegestryA_ReadFile = Chr(2&)
  Resume Rs1
  End Function

Private Function UnUnicode(ByRef xChar1 As String) As Boolean
  Dim xLong1 As Long
  xLong1 = Len(xChar1)
  If Left(xChar1, 2&) = Chr(255&) & Chr(254&) And ((xLong1 And 1&) = 0&) Then
    xChar1 = Replace(Mid(xChar1, 3&), vbNullChar, "")
    UnUnicode = (Len(xChar1) = xLong1 \ 2& - 1&)
    End If
  End Function




Public Function ConvertRegestryA(ByRef RegestryData As String, ByRef LogData As String, Optional ByVal ProgressControl As Long = 0&, Optional ByVal ProgressStart As Long = 0&, Optional ByVal ProgressTotal As Long = 0&, Optional ByVal ProgressQueue As Long = 0&) As Long
  Dim xCharA1() As String
  Dim xCharA2() As String
  Dim xLong1 As Long 'LineCounter
  'Dim xLong2 As Long 'ExeDataStartPos
  Dim xLong3 As Long 'TotalLines
  Dim xLong4 As Long
'  Dim xBool1 As Boolean
  Dim xChar1 As String
  Dim xChar2 As String
  Dim xChar3 As String
  Dim xCurrentKey As String
  Dim xKeyOpen As Long
  Dim xCurrentKeyID As Long
  Dim xLong2 As Long ' OutCounter
  
  xCharA1() = Split(RegestryData, vbCrLf)
  DoEvents
  xLong3 = UBound(xCharA1())
  RegestryData = ""
  ReDim xCharA2(xLong3)

  xLong1 = 1&
  Do Until xLong1 = xLong3 + 1&
    xChar1 = Trim(xCharA1(xLong1))
    'If (xLong1 Mod 64&) = 0& Then
      'ctProgressA1.ValueSet xLong1 / xLong3, Replace(LoadResEx_String(121), "$", Trim(Str(CInt(xLong1 * 100& / xLong3)))): DoEvents
    'Call ConvertRegestryA_Callback(xLong1, xLong3)
    ctProgressB_SetValue ProgressControl, ProgressStart + xLong1 / xLong3 * ProgressQueue, ProgressTotal
    xLong1 = xLong1 + 1&
    Select Case Left(xChar1, 2&)
      Case "[-"
        xCurrentKey = Mid(xChar1, 3&)
        xCurrentKeyID = GetCurrentKey(xCurrentKey)
        xKeyOpen = 3&
          xChar2 = Chr(xCurrentKeyID + &HA0&) & chrX(Len(xCurrentKey)) & xCurrentKey
      Case "[*" ' delete subkeys
        xCurrentKey = Mid(xChar1, 3&)
        xCurrentKeyID = GetCurrentKey(xCurrentKey)
        xKeyOpen = 1&
        xChar2 = Chr(xCurrentKeyID + &HB0&) & chrX(Len(xCurrentKey)) & xCurrentKey
      Case "[?" ' deletevalues
        xCurrentKey = Mid(xChar1, 3&)
        xCurrentKeyID = GetCurrentKey(xCurrentKey)
        xKeyOpen = 1&
        xChar2 = Chr(xCurrentKeyID + &HC0&) & chrX(Len(xCurrentKey)) & xCurrentKey
      Case "[&"
        xCurrentKey = Mid(xChar1, 3&)
        xCurrentKeyID = GetCurrentKey(xCurrentKey)
        xKeyOpen = 1&
        xChar2 = Chr(xCurrentKeyID + &H90&) & chrX(Len(xCurrentKey)) & xCurrentKey
        'xcurrentkey:
        ' -1 -> not currently used
        ' -2 -> error getting name -> -1&
      Case Else
      Select Case Trim(Left(xChar1, 1&))
        Case "["
          xCurrentKey = Mid(xChar1, 2&)
          xKeyOpen = 1&
          xCurrentKeyID = GetCurrentKey(xCurrentKey)
          xChar2 = Chr(xCurrentKeyID + &H80&) & chrX(Len(xCurrentKey)) & xCurrentKey
        Case ";"
        Case ""
        Case Else
        If xKeyOpen = 0& Then ' xCurrentKey = "" Then
          xChar2 = vbNullChar
          Else
          xChar2 = xChar1 'preserve xchar1 for logfile / error reporting
          xLong4 = GetParams(xChar2, xChar3, xCharA1(), xLong1, xLong3)
          If xLong4 = -1& Then
            xChar2 = vbNullChar
            Else
            xChar2 = xChar2 & vbNullChar & xChar3
            If xLong4 = 2& Then
              xChar2 = Chr(xLong4 * &H10& + (Len(xChar2) - 2&) \ &H10000) & chrX((Len(xChar2) - 2&) And &HFFFF&) & xChar2
              Else
              xChar2 = Chr(xLong4 * &H10& + Len(xChar2) \ &H10000) & chrX((Len(xChar2)) And &HFFFF&) & xChar2
              End If
            End If
          End If
        End Select
      End Select
    
    
    
    If xCurrentKeyID = -1& Or xChar2 = vbNullChar Then
      If xCurrentKeyID = -1& Then
        xCurrentKey = ""
        xKeyOpen = 0&
        xCurrentKeyID = 0&
        End If
      LogData = LogData & vbCrLf & Replace(LoadResEx_String(130), "$", Trim(Str(xLong1 + 1&))) & " " & xChar1
      xChar2 = ""
      ElseIf Not xChar2 = "" Then
      If xKeyOpen = 3& Then
        xKeyOpen = 2&
        ElseIf xKeyOpen = 2& Then
        xKeyOpen = 1&
        'RegestryData = RegestryData & Chr(xCurrentKeyID + &H80&) & chrX(Len(xCurrentKey)) & xCurrentKey
        xCharA2(xLong2) = Chr(xCurrentKeyID + &H80&) & chrX(Len(xCurrentKey)) & xCurrentKey
        xLong2 = xLong2 + 1&
        End If
      'RegestryData = RegestryData & xChar2
      xCharA2(xLong2) = xChar2
      xLong2 = xLong2 + 1&
      xChar2 = ""
      End If
    Loop
  LogData = Mid(LogData, 3&)
  If Not xLong2 = 0& Then
    'Stop
    ReDim Preserve xCharA2(xLong2 - 1&)
    RegestryData = Join(xCharA2(), "")
    DoEvents
    End If
  End Function

Private Function GetCurrentKey(ByRef CompleteKey As String) As Long
  Static xLong1 As Long
  
  CompleteKey = Trim(CompleteKey)
  If Right(CompleteKey, 1&) = "]" Then
    CompleteKey = Left(CompleteKey, Len(CompleteKey) - 1&)
    xLong1 = InStr(CompleteKey & "\", "\") - 1&
    Select Case UCase(Left(CompleteKey, xLong1))
      Case "HKEY_CLASSES_ROOT": GetCurrentKey = &H0&
      Case "HKEY_CURRENT_USER": GetCurrentKey = &H1&
      Case "HKEY_LOCAL_MACHINE": GetCurrentKey = &H2&
      Case "HKEY_USERS": GetCurrentKey = &H3&
      Case "HKEY_PERFORMANCE_DATA": GetCurrentKey = &H4&
      Case "HKEY_CURRENT_CONFIG": GetCurrentKey = &H5&
      Case "HKEY_DYN_DATA": GetCurrentKey = &H6&
      Case Else
        GetCurrentKey = -1&
      End Select
    Else
    GetCurrentKey = -1&
    End If
  CompleteKey = Mid(CompleteKey, xLong1 + 2&)
  End Function

Private Function chrX(ByVal xLong1 As Long) As String
  chrX = Chr(xLong1 \ &H100&) & Chr(xLong1 And &HFF&)
  End Function

' This is now isolated, xdata/counter byref if hex ... \ is userd to process
' Also need to update processbar here, so xtotal is passed too ... byref! but not overwritten
Private Function GetParams(ByRef xName As String, ByRef xData As String, ByRef xArray() As String, ByRef xCounter As Long, ByRef xTotal As Long) As Long ', ByRef ProgressStart As Long, ByRef ProgressTotal As Long, ByRef ProgressQueue As Long) As Long
  'returns multiplier or -1
  
  Static xLong1 As Long
  Static xChar1 As String
  
  ' This should now make it real "..."="..." or @=... compatible
  ' When finished, on each side chr(0) has to be replaced with "
  ' \\ is also fixed here to \
  'xData = LTrim(Replace(Replace(xName, "\" & Chr(34), vbNullChar), "\\", "\"))
  xData = LTrim(Replace(Replace(Replace(xName, "\\", Chr(1&)), "\" & Chr(34), vbNullChar), Chr(1&), "\"))
  
  If Left(xData, 2&) = "@=" Then
    xName = ""
    xData = LTrim(Mid(xData, 2&))
    ElseIf Left(xData, 1&) = Chr(34&) Then
    GetParams = InStr(2&, xData, Chr(34&))
    If GetParams = 0& Then
      GetParams = -1&
      Else
      xName = Mid(xData, 2&, GetParams - 2&)
      xData = LTrim(Mid(xData, GetParams + 1&))
      End If
    Else
    GetParams = -1&
    End If
  
  If Not GetParams = -1& Then
    If Left(xData, 1&) = "=" Then
      xData = LTrim(Mid(xData, 2&))
      xChar1 = LCase(xData)
      If Left(xData, 1&) = Chr(34) Then
        GetParams = InStr(2&, xData, Chr(34&))
        If GetParams = 0& Then
          GetParams = -1&
          Else
          If LTrim(Mid(xData, GetParams + 1&)) = "" Then
            xData = Replace(Mid(xData, 2&, GetParams - 2&), vbNullChar, Chr(34&))
            GetParams = 1&
            Else
            GetParams = -1&
            End If
          End If
        ElseIf Left(xChar1, 6&) = "dword:" Then
        xData = Mid(xData, 7&)
        GetParams = ValidDWord(xData)
        ' Using external function
        ElseIf Left(xChar1, 3&) = "hex" Then
          ' here both hex(): and hex: because both may use ...\ multilines
        Select Case Left(xChar1, 4&)
          Case "hex:"
            GetParams = 3&
            xChar1 = LTrim(Mid(xData, 5&))
          Case "hex("
            xData = LTrim(Mid(xData, 5&))
            xLong1 = InStr(xData, ")")
            If xLong1 = 0& Then
              GetParams = -1&
              Else
              xChar1 = Trim(Left(xData, xLong1 - 1&))
              GetParams = AntHex(xChar1)
              If Not GetParams = -1& Then
                If Hex(GetParams) = UCase(xChar1) Then
                  xData = LTrim(Mid(xData, xLong1 + 1&))
                  If Left(xData, 1&) = ":" Then
                    xChar1 = Mid(xData, 2&)
                    xName = chrX(GetParams) & Replace(xName, vbNullChar, Chr(34&))
                    GetParams = 2&
                    Else
                    GetParams = -1&
                    End If
                  Else
                  GetParams = -1&
                  End If
                End If
              End If
          Case Else
            GetParams = -1&
          End Select
          
        If Not GetParams = -1& Then
          'xData = ","
          xData = ""
          Do
            xChar1 = RTrim(xChar1)
            If Right(xChar1, 2&) = ",\" Then
              If xCounter = xTotal Then
                GetParams = -1&
                Exit Do
                Else
                xChar1 = Left(xChar1, Len(xChar1) - 2&)
                If ValidHex(xData, xChar1) Then
                  '''xData = xData & RTrim(Left(xChar1, Len(xChar1) - 1&))
                  xChar1 = LTrim(xArray(xCounter))
                  'If (xCounter And 16&) = 0& Then ctProgressA1.ValueSet xCounter / xTotal, Replace(LoadResEx_String(121), "$", Trim(Str(CInt(xCounter * 100& / xTotal)))): DoEvents
                  'ctProgressB_SetValue ProgressControl, ProgressStart + xCounter / Total * ProgressQueue, ProgressTotal
                  xCounter = xCounter + 1&
                  Else
                  GetParams = -1&
                  Exit Do
                  End If
                End If
              Else
              If Not ValidHex(xData, xChar1) Then
                GetParams = -1&
                End If
              Exit Do
              End If
            Loop
          'If Not GetParams = -1& Then
          '  xData = Mid(xData, 2&)
          '  End If
          End If
        
        ElseIf RTrim(xData) = "-" Then
        xData = ""
        GetParams = 0&
        ElseIf xName = "" And xData = "" Then
        xData = ""
        GetParams = 0&
        Else
        GetParams = -1&
        End If
      Else
      GetParams = -1&
      End If
    End If
          
  If Not (GetParams = -1& Or GetParams = 2&) Then
    xName = Replace(xName, vbNullChar, Chr(34&))
    End If
  End Function

Private Function ValidDWord(ByRef xChar1 As String) As Long
Static xLong1 As Long
Static xLong2 As Long
Static xLong3 As Long
Dim xChar2 As String

ValidDWord = 4&
If Len(xChar1) = 8& Then
  For xLong1 = 7& To 1& Step -2&
    xLong2 = GetHexValueByte(Mid(xChar1, xLong1, 1&))
    xLong3 = GetHexValueByte(Mid(xChar1, xLong1 + 1&, 1&))
    If xLong2 = -1& Or xLong3 = -1& Then
      ValidDWord = -1&
      Exit For
      Else
      xChar2 = xChar2 + Chr(16& * xLong2 + xLong3)
      End If
    Next
  xChar1 = xChar2
  Else
  ValidDWord = -1&
  End If
End Function

Private Function ValidHex(ByRef HexOld As String, ByVal HexNew As String) As Boolean
Static xLong1 As Long
Static xLong2 As Long
Static xLong3 As Long
Dim xChar1 As String

HexNew = "," & Replace(Replace(Replace(HexNew, " ", ""), ",,", ",00,"), ",,", ",00,")
xLong1 = Len(HexNew)
xLong2 = xLong1 \ 3&

ValidHex = True
If (xLong2) * 3& = xLong1 Then
  For xLong1 = 0& To xLong2 - 1&
    xLong3 = xLong1 * 3& + 1&
    If Mid(HexNew, xLong3, 1&) = "," Then
      xLong2 = GetHexValueByte(Mid(HexNew, xLong3 + 1&, 1&))
      xLong3 = GetHexValueByte(Mid(HexNew, xLong3 + 2&, 2&))
      If xLong2 = -1& Or xLong3 = -1& Then
        ValidHex = False
        Exit For
        Else
        xChar1 = xChar1 & Chr(xLong2 * 16& + xLong3)
        End If
      Else
      ValidHex = False
      Exit For
      End If
    Next
  ElseIf Not xLong1 = 1& Then
  ValidHex = False
  End If

If ValidHex Then
  HexOld = HexOld & xChar1
  End If
End Function

Private Function AntHex(ByVal xChar1 As String) As Long
Static xLong1 As Long
Static xLong2 As Long
Static xLong3 As Long

xLong2 = Len(xChar1) - 1&

For xLong1 = 0& To xLong2
  xLong3 = GetHexValueByte(Mid(xChar1, xLong1 + 1&, 1&))
  If xLong3 = -1& Then
    AntHex = -1&
    Exit For
    Else
    AntHex = AntHex + (16& ^ (xLong2 - xLong1)) * xLong3
    End If
  Next
End Function

Private Function GetHexValueByte(ByVal xChar1 As String) As Long
GetHexValueByte = InStr("0123456789ABCDEF", UCase(Left(xChar1, 1&))) - 1&
End Function



      'ctProgressA1.ValueSet xLong1 / xLong3, Replace(LoadResEx_String(121), "$", Trim(Str(CInt(xLong1 * 100& / xLong3)))): DoEvents
