Computertips

' Pervasive Database
Private Sub My_CREATETABLE()
    ' ITEMSTOCK
    sSQL = "CREATE TABLE """ & "ITEMSTOCK" & """(" & Chr(13)   ' table name
    sSQL = sSQL & Chr(34) & "DETAILNUM" & Chr(34) & " SMALLINT NOT NULL," & Chr(13)
    sSQL = sSQL & Chr(34) & "DOCTYPE" & Chr(34) & " SMALLINT," & Chr(13)
    sSQL = sSQL & Chr(34) & "DOCNUM" & Chr(34) & " CHAR(22)," & Chr(13)
    sSQL = sSQL & Chr(34) & "ITEMCODE" & Chr(34) & " CHAR(24)," & Chr(13)
    sSQL = sSQL & Chr(34) & "AUDTDATE" & Chr(34) & " DECIMAL(19,0)," & Chr(13)
    sSQL = sSQL & Chr(34) & "DAY" & Chr(34) & " DECIMAL(19,0)," & Chr(13)
    sSQL = sSQL & Chr(34) & "MONTH" & Chr(34) & " DECIMAL(19,0)," & Chr(13)
    sSQL = sSQL & Chr(34) & "YEAR" & Chr(34) & " DECIMAL(19,0)," & Chr(13)
    sSQL = sSQL & Chr(34) & "VENDOR" & Chr(34) & " CHAR(60)," & Chr(13)
    sSQL = sSQL & Chr(34) & "CUSTOMER" & Chr(34) & " CHAR(60)," & Chr(13)
    sSQL = sSQL & Chr(34) & "UNITCOSTIN" & Chr(34) & " DECIMAL(19,4)," & Chr(13)
    sSQL = sSQL & Chr(34) & "UNITCOSTOUT" & Chr(34) & " DECIMAL(19,4)," & Chr(13)
    sSQL = sSQL & Chr(34) & "QUANTITYIN" & Chr(34) & " DECIMAL(19,4)," & Chr(13)
    sSQL = sSQL & Chr(34) & "QUANTITYOUT" & Chr(34) & " DECIMAL(19,4)," & Chr(13)
    sSQL = sSQL & Chr(34) & "QTYBALANCE" & Chr(34) & " DECIMAL(19,4)," & Chr(13)
    sSQL = sSQL & Chr(34) & "QTYOPENINGBALANCE" & Chr(34) & " DECIMAL(19,4)," & Chr(13)
    sSQL = sSQL & Chr(34) & "REMARK" & Chr(34) & " CHAR(60)," & Chr(13)
    sSQL = sSQL & "PRIMARY KEY (" & Chr(34) & "DETAILNUM" & Chr(34) & ")" & Chr(13)
    sSQL = sSQL & ");" & Chr(13)
    sSQL = sSQL & "CREATE UNIQUE NOT MODIFIABLE INDEX " & Chr(34) & "PK_DETAILNUM" & Chr(34) & _
    " ON " & Chr(34) & "ITEMSTOCK" & Chr(34) & "(" & Chr(34) & "DETAILNUM" & Chr(34) & ");"

    ' ADBO Connection Execute
    cnn.CommandTimeout = 300
    cnn.Execute sSQL

Private Function GetKeyInfo(ByVal section As Long, ByVal key_name As String, ByVal indent As Integer) As String
Dim subkeys As Collection
Dim subkey_values As Collection
Dim subkey_num As Integer
Dim subkey_name As String
Dim subkey_value As String
Dim length As Long
Dim hKey As Long
Dim txt As String
Dim subkey_txt As String
Dim value_num As Long
Dim value_name_len As Long
Dim value_name As String
Dim reserved As Long
Dim value_type As Long
Dim value_string As String
Dim value_data(1 To 1024) As Byte
Dim value_data_len As Long
Dim i As Integer

    Set subkeys = New Collection
    Set subkey_values = New Collection
   
    ' Open the key.
    If RegOpenKeyEx(section, _
        key_name, _
        0&, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS _
    Then
        MsgBox "Error opening key."
        Exit Function
    End If

    ' Enumerate the key's values.
    value_num = 0
    k = 0
    Do
        value_name_len = 1024
        value_name = Space$(value_name_len)
        value_data_len = 1024

        If RegEnumValue(hKey, value_num, _
            value_name, value_name_len, 0, _
            value_type, value_data(1), value_data_len) _
                <> ERROR_SUCCESS Then Exit Do

        value_name = Left$(value_name, value_name_len)

        Select Case value_type
            Case REG_BINARY
                txt = txt & Space$(indent) & "> " & value_name & " = [binary]" & vbCrLf
            Case REG_DWORD
                value_string = "&H" & _
                    Format$(Hex$(value_data(4)), "00") & _
                    Format$(Hex$(value_data(3)), "00") & _
                    Format$(Hex$(value_data(2)), "00") & _
                    Format$(Hex$(value_data(1)), "00")
                txt = txt & Space$(indent) & "> " & value_name & " = " & value_string & vbCrLf
            Case REG_DWORD_BIG_ENDIAN
                txt = txt & Space$(indent) & "> " & value_name & " = [dword big endian]" & vbCrLf
            Case REG_DWORD_LITTLE_ENDIAN
                txt = txt & Space$(indent) & "> " & value_name & " = [dword little endian]" & vbCrLf
            Case REG_EXPAND_SZ
                txt = txt & Space$(indent) & "> " & value_name & " = [expand sz]" & vbCrLf
            Case REG_FULL_RESOURCE_DESCRIPTOR
                txt = txt & Space$(indent) & "> " & value_name & " = [full resource descriptor]" & vbCrLf
            Case REG_LINK
                txt = txt & Space$(indent) & "> " & value_name & " = [link]" & vbCrLf
            Case REG_MULTI_SZ
                txt = txt & Space$(indent) & "> " & value_name & " = [multi sz]" & vbCrLf
            Case REG_NONE
                txt = txt & Space$(indent) & "> " & value_name & " = [none]" & vbCrLf
            Case REG_RESOURCE_LIST
                txt = txt & Space$(indent) & "> " & value_name & " = [resource list]" & vbCrLf
            Case REG_RESOURCE_REQUIREMENTS_LIST
                txt = txt & Space$(indent) & "> " & value_name & " = [resource requirements list]" & vbCrLf
            Case REG_SZ
                value_string = ""
                For i = 1 To value_data_len - 1
                    value_string = value_string & Chr$(value_data(i))
                Next i
                If UCase(value_string) = UCase("Pervasive ODBC Engine Interface") Then
                    txt = txt & Space$(indent) & " > " & value_name & vbCrLf
                    cboODBC.AddItem Trim("" & value_name), k   ' Show ODBC name to cboODBC
                    k = k + 1
                End If
                'txt = txt & Space$(indent) & "> " & value_name & " = """ & value_string & """" & vbCrLf
        End Select

        value_num = value_num + 1
    Loop

    ' Enumerate the subkeys.
    subkey_num = 0
    Do
        ' Enumerate subkeys until we get an error.
        length = 256
        subkey_name = Space$(length)
        If RegEnumKey(hKey, subkey_num, _
            subkey_name, length) _
                <> ERROR_SUCCESS Then Exit Do
        subkey_num = subkey_num + 1
       
        subkey_name = Left$(subkey_name, InStr(subkey_name, Chr$(0)) - 1)
        subkeys.Add subkey_name
   
        ' Get the subkey's value.
        length = 256
        subkey_value = Space$(length)
        If RegQueryValue(hKey, subkey_name, _
            subkey_value, length) _
            <> ERROR_SUCCESS _
        Then
            subkey_values.Add "Error"
        Else
            ' Remove the trailing null character.
            subkey_value = Left$(subkey_value, length - 1)
            subkey_values.Add subkey_value
        End If
    Loop
   
    ' Close the key.
    If RegCloseKey(hKey) <> ERROR_SUCCESS Then
        MsgBox "Error closing key."
    End If

    ' Recursively get information on the keys.
    For subkey_num = 1 To subkeys.Count
        subkey_txt = GetKeyInfo(section, key_name & "\" & subkeys(subkey_num), indent + 4)
        txt = txt & Space(indent) & _
            subkeys(subkey_num) & _
            ": " & subkey_values(subkey_num) & vbCrLf & _
            subkey_txt
    Next subkey_num

    GetKeyInfo = txt
End Function