[AccessD] Registry tweaks

MartyConnelly martyconnelly at shaw.ca
Tue Dec 2 13:14:43 CST 2003


Yes, I see what you mean. I didn't realize Guantanamo Bay was a seperate 
country.
Recognized by the soverign state of Microsoft, no doubt ;)

Charlotte Foust wrote:

>The one caution I would suggest here is that the country names are
>coming from a telephony key.  The problem is that there are separate
>"countries" which happen to be islands and which share an area code, so
>some of those country names may not be entirely reliable.  
>
>I always have to refresh my memory on callbacks as well, but it's
>perfectly possible to create a recordset entirely in memory using ADO
>and then persist it to either an ADTG or XML format instead of creating
>a table.
>
>Charlotte Foust
>
>-----Original Message-----
>From: MartyConnelly [mailto:martyconnelly at shaw.ca] 
>Sent: Monday, December 01, 2003 6:39 PM
>To: Access Developers discussion and problem solving
>Subject: Re: [AccessD] Registry tweaks
>
>
>
>Just use sortcountrylist  function as intial call. You don't have to 
>QuikSort just put in a query after moving to a table
>I was going to put into an array at one point. Should give you 230 
>countries.
>
>I find it a pain to use callbacks. I keep having to refresh my memory as
>
>to how to use them.
>
>
>Public Const HKEY_CLASSES_ROOT As Long = &H80000000
>Public Const HKEY_CURRENT_USER = &H80000001
>Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
>Public Const HKEY_USERS As Long = &H80000003
>Public Const HKEY_PERFORMANCE_DATA As Long = &H80000004
>Public Const HKEY_CURRENT_CONFIG As Long = &H80000005
>Public Const HKEY_DYN_DATA As Long = &H80000006
>
>Const ValueName As String = "Name"
>Const MasterKey As String = 
>"SOFTWARE\Microsoft\Windows\CurrentVersion\Telephony\Country List\"
>Public Function getregcountries() As String 'Enumerate the keys inside
>the Registry key: ' parts of this from
>http://www.vb-helper.com/howto_list_countries.html
>'    HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\
>'    CurrentVersion\Telephony\Country List\
>   
>    Dim KeyCol As Collection
>    Dim CountryCol As Collection
>    Dim strCountry As String
>    strCountry = ""
>    If CheckRegistryKey(HKEY_LOCAL_MACHINE, MasterKey) Then
>
>        Set KeyCol = EnumRegistryKeys(HKEY_LOCAL_MACHINE, MasterKey)
>        Dim TheKey As Variant
>        Set CountryCol = New Collection
>
>        For Each TheKey In KeyCol
>             If TheKey <> "800" And GetRegistryValue(HKEY_LOCAL_MACHINE,
>
>MasterKey & TheKey, "InternationalRule", "") <> "00EFG#" Then
>                'CboCountry.AddItem GetRegistryValue(HKEY_LOCAL_MACHINE,
>
>MasterKey & TheKey, ValueName, "")
>                Debug.Print GetRegistryValue(HKEY_LOCAL_MACHINE, 
>MasterKey & TheKey, ValueName, "")
>                strCountry = strCountry & 
>GetRegistryValue(HKEY_LOCAL_MACHINE, MasterKey & TheKey, ValueName, "") 
>& ";"
>             End If
>        Next
>    End If
>    getregcountries = strCountry
>End Function
>
>
>Function SortCountriesString() As String
>Dim arrtemp As Variant
>Dim arrCountries(300) As String
>Dim strCountries As String
>Dim strOutCountries As String
>Dim i As Long
> ' Get Countries from Registry
>  strCountries = getregcountries
>  ' Move countries string to array unsorted
>  arrtemp = Split(strCountries, ";")
>  'put variant array into string array
>   For i = LBound(arrtemp) To UBound(arrtemp)
>        arrCountries(i) = arrtemp(i)
>   Next i
>   ' now sort array by country name
>  Quicksort arrCountries, LBound(arrtemp), UBound(arrtemp)
>   'put array into string for combobox maybe too long > 2048 bytes
>    For i = LBound(arrtemp) To UBound(arrtemp)
>      strOutCountries = strOutCountries & arrCountries(i) & ";"
>    Next i
>   
>    SortCountriesString = strOutCountries
>  'Debug.Print Len(SortCountriesString)
>  ' put sorted array into table
> 
>   MoveIntoTable arrCountries(), UBound(arrtemp)
>End Function
>
>Function MoveIntoTable(arrCountries() As String, imax As Long) Dim rs As
>Recordset Dim iRow As Integer, iCol As Integer Dim db As Database Set db
>= CurrentDb 'pre create table with 1 text field "Country Name" Set rs =
>db.OpenRecordset("CountryName") If rs.RecordCount > 1 Then
>   MsgBox "table exists already"
>   Exit Function
>End If
>With rs
>    For iRow = 0 To imax
>        .AddNew
>        ' 0'th field is autonumber
>            .Fields(1) = arrCountries(iRow)
>        .Update
>    Next
>    .Close
>End With
>Set rs = Nothing
>
>End Function
> 
>Public Sub Quicksort(list() As String, ByVal min As Long, _
>    ByVal max As Long)
>Dim med_value As String
>Dim hi As Long
>Dim lo As Long
>Dim i As Long
>
>    ' If min >= max, the list contains 0 or 1 items so it
>    ' is sorted.
>    If min >= max Then Exit Sub
>
>    ' Pick the dividing value.
>    i = Int((max - min + 1) * Rnd + min)
>    med_value = list(i)
>
>    ' Swap it to the front.
>    list(i) = list(min)
>
>    lo = min
>    hi = max
>    Do
>        ' Look down from hi for a value < med_value.
>        Do While list(hi) >= med_value
>            hi = hi - 1
>            If hi <= lo Then Exit Do
>        Loop
>        If hi <= lo Then
>            list(lo) = med_value
>            Exit Do
>        End If
>
>        ' Swap the lo and hi values.
>        list(lo) = list(hi)
>       
>        ' Look up from lo for a value >= med_value.
>        lo = lo + 1
>        Do While list(lo) < med_value
>            lo = lo + 1
>            If lo >= hi Then Exit Do
>        Loop
>        If lo >= hi Then
>            lo = hi
>            list(hi) = med_value
>            Exit Do
>        End If
>       
>        ' Swap the lo and hi values.
>        list(hi) = list(lo)
>    Loop
>   
>    ' Sort the two sublists.
>    Quicksort list(), min, lo - 1
>    Quicksort list(), lo + 1, max
>End Sub
>
>'registry utilities in seperate module
>
> Option Compare Database
>Option Explicit
>
>Public Const HKEY_CLASSES_ROOT As Long = &H80000000
>Public Const HKEY_CURRENT_USER = &H80000001
>Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
>Public Const HKEY_USERS As Long = &H80000003
>Public Const HKEY_PERFORMANCE_DATA As Long = &H80000004
>Public Const HKEY_CURRENT_CONFIG As Long = &H80000005
>Public Const HKEY_DYN_DATA As Long = &H80000006
>
>
>
>
>Const REG_SZ = 1
>Const REG_EXPAND_SZ = 2
>Const REG_BINARY = 3
>Const REG_DWORD = 4
>Const REG_MULTI_SZ = 7
>Const ERROR_MORE_DATA = 234
>Const KEY_READ = &H20019  ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
>                          ' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And
>(Not
>                          ' SYNCHRONIZE))
>Const REG_OPENED_EXISTING_KEY = &H2
>
>Const KEY_WRITE = &H20006  '((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or
>                           ' KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
>
>
>Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
>    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
>    ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
>    ByVal cbData As Long) As Long
>
>
>Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
>    "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 
>As Long
>
>
>
>Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" 
>(dest As _
>    Any, source As Any, ByVal numBytes As Long)
>
>
>Private Declare Function RegEnumKey Lib "advapi32.dll" Alias
>"RegEnumKeyA" _
>    (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String,
>_
>    ByVal cbName As Long) As Long
>
>Private Declare Function RegEnumValue Lib "advapi32.dll" Alias 
>"RegEnumValueA" _
>    (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As 
>String, _
>    lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
>    lpData As Any, lpcbData 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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As 
>Long) As _
>    Long
>
>
>Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
>    "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
>    ByVal Reserved As Long, ByVal lpClass As Long, ByVal dwOptions As 
>Long, _
>    ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, _
>    phkResult As Long, lpdwDisposition 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, lpData As Any, _
>    lpcbData As Long) As Long
>
>Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias 
>"RegDeleteKeyA" _
>    (ByVal hKey As Long, ByVal lpSubKey As String) As Long
>
>
>
>Sub DeleteRegistryKey(ByVal hKey As Long, ByVal KeyName As String)
>    RegDeleteKey hKey, KeyName
>End Sub
>
>
>
>
>Function DeleteRegistryValue(ByVal hKey As Long, ByVal KeyName As
>String, _
>    ByVal ValueName As String) As Boolean
>    Dim handle As Long
>   
>    ' Open the key, exit if not found
>    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then Exit
>Function
>   
>    ' Delete the value (returns 0 if success)
>    DeleteRegistryValue = (RegDeleteValue(handle, ValueName) = 0)
>    ' Close the handle
>    RegCloseKey handle
>End Function
>
>Function CheckRegistryKey(ByVal hKey As Long, ByVal KeyName As String)
>As _
>    Boolean
>    Dim handle As Long
>    ' Try to open the key
>    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) = 0 Then
>        ' The key exists
>        CheckRegistryKey = True
>        ' Close it before exiting
>        RegCloseKey handle
>    End If
>End Function
>
>
>Function CreateRegistryKey(ByVal hKey As Long, ByVal KeyName As String)
>As _
>    Boolean
>    Dim handle As Long, disposition As Long
>   
>    If RegCreateKeyEx(hKey, KeyName, 0, 0, 0, 0, 0, handle, disposition)
>
>Then
>        Err.Raise 1001, , "Unable to create the registry key"
>    Else
>        ' Return True if the key already existed.
>        CreateRegistryKey = (disposition = REG_OPENED_EXISTING_KEY)
>        ' Close the key.
>        RegCloseKey handle
>    End If
>End Function
>
>
>Function EnumRegistryKeys(ByVal hKey As Long, ByVal KeyName As String)
>As _
>    Collection
>    Dim handle As Long
>    Dim length As Long
>    Dim index As Long
>    Dim subkeyName As String
>   
>    ' initialize the result collection
>    Set EnumRegistryKeys = New Collection
>   
>    ' Open the key, exit if not found
>    If Len(KeyName) Then
>        If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit 
>Function
>        ' in all case the subsequent functions use hKey
>        hKey = handle
>    End If
>   
>    Do
>        ' this is the max length for a key name
>        length = 260
>        subkeyName = Space$(length)
>        ' get the N-th key, exit the loop if not found
>        If RegEnumKey(hKey, index, subkeyName, length) Then Exit Do
>       
>        ' add to the result collection
>        subkeyName = Left$(subkeyName, InStr(subkeyName, vbNullChar) -
>1)
>        EnumRegistryKeys.Add subkeyName, subkeyName
>        ' prepare to query for next key
>        index = index + 1
>    Loop
>  
>    ' Close the key, if it was actually opened
>    If handle Then RegCloseKey handle
>       
>End Function
>
>
>Function EnumRegistryValues(ByVal hKey As Long, ByVal KeyName As String)
>
>As _
>    Collection
>    Dim handle As Long
>    Dim index As Long
>    Dim valueType As Long
>    Dim name As String
>    Dim nameLen As Long
>    Dim resLong As Long
>    Dim resString As String
>    Dim dataLen As Long
>    Dim valueInfo(0 To 1) As Variant
>    Dim retVal As Long
>   
>    ' initialize the result
>    Set EnumRegistryValues = New Collection
>   
>    ' Open the key, exit if not found.
>    If Len(KeyName) Then
>        If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit 
>Function
>        ' in all cases, subsequent functions use hKey
>        hKey = handle
>    End If
>   
>    Do
>        ' this is the max length for a key name
>        nameLen = 260
>        name = Space$(nameLen)
>        ' prepare the receiving buffer for the value
>        dataLen = 4096
>        ReDim resBinary(0 To dataLen - 1) As Byte
>       
>        ' read the value's name and data
>        ' exit the loop if not found
>        retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, 
>valueType, _
>            resBinary(0), dataLen)
>       
>        ' enlarge the buffer if you need more space
>        If retVal = ERROR_MORE_DATA Then
>            ReDim resBinary(0 To dataLen - 1) As Byte
>            retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&,
>_
>                valueType, resBinary(0), dataLen)
>        End If
>        ' exit the loop if any other error (typically, no more values)
>        If retVal Then Exit Do
>       
>        ' retrieve the value's name
>        valueInfo(0) = Left$(name, nameLen)
>       
>        ' return a value corresponding to the value type
>        Select Case valueType
>            Case REG_DWORD
>                CopyMemory resLong, resBinary(0), 4
>                valueInfo(1) = resLong
>            Case REG_SZ, REG_EXPAND_SZ
>                ' copy everything but the trailing null char
>                resString = Space$(dataLen - 1)
>                CopyMemory ByVal resString, resBinary(0), dataLen - 1
>                valueInfo(1) = resString
>            Case REG_BINARY
>                ' shrink the buffer if necessary
>                If dataLen < UBound(resBinary) + 1 Then
>                    ReDim Preserve resBinary(0 To dataLen - 1) As Byte
>                End If
>                valueInfo(1) = resBinary()
>            Case REG_MULTI_SZ
>                ' copy everything but the 2 trailing null chars
>                resString = Space$(dataLen - 2)
>                CopyMemory ByVal resString, resBinary(0), dataLen - 2
>                valueInfo(1) = resString
>            Case Else
>                ' Unsupported value type - do nothing
>        End Select
>       
>        ' add the array to the result collection
>        ' the element's key is the value's name
>        EnumRegistryValues.Add valueInfo, valueInfo(0)
>       
>        index = index + 1
>    Loop
>  
>    ' Close the key, if it was actually opened
>    If handle Then RegCloseKey handle
>       
>End Function
>Function EnumRegistryValuesEx(ByVal hKey As Long, ByVal KeyName As 
>String) As _
>    Collection
>    Dim handle As Long
>    Dim index As Long
>    Dim valueType As Long
>    Dim name As String
>    Dim nameLen As Long
>    Dim resLong As Long
>    Dim resString As String
>    Dim dataLen As Long
>    Dim valueInfo(0 To 2) As Variant
>    Dim retVal As Long
>   
>    ' initialize the result
>    Set EnumRegistryValuesEx = New Collection
>   
>    ' Open the key, exit if not found.
>    If Len(KeyName) Then
>        If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit 
>Function
>        ' in all cases, subsequent functions use hKey
>        hKey = handle
>    End If
>   
>    Do
>        ' this is the max length for a key name
>        nameLen = 260
>        name = Space$(nameLen)
>        ' prepare the receiving buffer for the value
>        dataLen = 4096
>        ReDim resBinary(0 To dataLen - 1) As Byte
>       
>        ' read the value's name and data
>        ' exit the loop if not found
>        retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, 
>valueType, _
>            resBinary(0), dataLen)
>       
>        ' enlarge the buffer if you need more space
>        If retVal = ERROR_MORE_DATA Then
>            ReDim resBinary(0 To dataLen - 1) As Byte
>            retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&,
>_
>                valueType, resBinary(0), dataLen)
>        End If
>        ' exit the loop if any other error (typically, no more values)
>        If retVal Then Exit Do
>       
>        ' retrieve the value's name
>        valueInfo(0) = Left$(name, nameLen)
>       
>        ' return a value corresponding to the value type
>        Select Case valueType
>            Case REG_DWORD
>                CopyMemory resLong, resBinary(0), 4
>                valueInfo(1) = resLong
>                valueInfo(2) = vbLong
>            Case REG_SZ, REG_EXPAND_SZ
>                ' copy everything but the trailing null char
>                resString = Space$(dataLen - 1)
>                CopyMemory ByVal resString, resBinary(0), dataLen - 1
>                valueInfo(1) = resString
>                valueInfo(2) = vbString
>            Case REG_BINARY
>                ' shrink the buffer if necessary
>                If dataLen < UBound(resBinary) + 1 Then
>                    ReDim Preserve resBinary(0 To dataLen - 1) As Byte
>                End If
>                valueInfo(1) = resBinary()
>                valueInfo(2) = vbArray + vbByte
>            Case REG_MULTI_SZ
>                ' copy everything but the 2 trailing null chars
>                resString = Space$(dataLen - 2)
>                CopyMemory ByVal resString, resBinary(0), dataLen - 2
>                valueInfo(1) = resString
>                valueInfo(2) = vbString
>            Case Else
>                ' Unsupported value type - do nothing
>        End Select
>       
>        ' add the array to the result collection
>        ' the element's key is the value's name
>        EnumRegistryValuesEx.Add valueInfo, valueInfo(0)
>       
>        index = index + 1
>    Loop
>  
>    ' Close the key, if it was actually opened
>    If handle Then RegCloseKey handle
>       
>End Function
>
>
>Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
>    ByVal ValueName As String, Optional DefaultValue As Variant) As
>Variant
>    Dim handle As Long
>    Dim resLong As Long
>    Dim resString As String
>    Dim resBinary() As Byte
>    Dim length As Long
>    Dim retVal As Long
>    Dim valueType As Long
>   
>    ' Prepare the default result
>    GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
>   
>    ' Open the key, exit if not found.
>    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
>        Exit Function
>    End If
>   
>    ' prepare a 1K receiving resBinary
>    length = 1024
>    ReDim resBinary(0 To length - 1) As Byte
>   
>    ' read the registry key
>    retVal = RegQueryValueEx(handle, ValueName, 0, valueType, 
>resBinary(0), _
>        length)
>    ' if resBinary was too small, try again
>    If retVal = ERROR_MORE_DATA Then
>        ' enlarge the resBinary, and read the value again
>        ReDim resBinary(0 To length - 1) As Byte
>        retVal = RegQueryValueEx(handle, ValueName, 0, valueType, 
>resBinary(0), _
>            length)
>    End If
>   
>    ' return a value corresponding to the value type
>    Select Case valueType
>        Case REG_DWORD
>            CopyMemory resLong, resBinary(0), 4
>            GetRegistryValue = resLong
>        Case REG_SZ, REG_EXPAND_SZ
>            ' copy everything but the trailing null char
>            resString = Space$(length - 1)
>            CopyMemory ByVal resString, resBinary(0), length - 1
>            GetRegistryValue = resString
>        Case REG_BINARY
>            ' resize the result resBinary
>            If length <> UBound(resBinary) + 1 Then
>                ReDim Preserve resBinary(0 To length - 1) As Byte
>            End If
>            GetRegistryValue = resBinary()
>        Case REG_MULTI_SZ
>            ' copy everything but the 2 trailing null chars
>            resString = Space$(length - 2)
>            CopyMemory ByVal resString, resBinary(0), length - 2
>            GetRegistryValue = resString
>        Case Else
>            RegCloseKey handle
>            Err.Raise 1001, , "Unsupported value type"
>    End Select
>   
>    ' close the registry key
>    RegCloseKey handle
>End Function
>
>
> 
>
>Function SetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
>    ByVal ValueName As String, value As Variant) As Boolean
>    Dim handle As Long
>    Dim lngValue As Long
>    Dim strValue As String
>    Dim binValue() As Byte
>    Dim length As Long
>    Dim retVal As Long
>   
>    ' Open the key, exit if not found
>    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then
>        Exit Function
>    End If
>
>    ' three cases, according to the data type in Value
>    Select Case VarType(value)
>        Case vbInteger, vbLong
>            lngValue = value
>            retVal = RegSetValueEx(handle, ValueName, 0, REG_DWORD, 
>lngValue, 4)
>        Case vbString
>            strValue = value
>            retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal 
>strValue, _
>                Len(strValue))
>        Case vbArray + vbByte
>            binValue = value
>            length = UBound(binValue) - LBound(binValue) + 1
>            retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, _
>                binValue(LBound(binValue)), length)
>        Case Else
>            RegCloseKey handle
>            Err.Raise 1001, , "Unsupported value type"
>    End Select
>   
>    ' Close the key and signal success
>    RegCloseKey handle
>    ' signal success if the value was written correctly
>    SetRegistryValue = (retVal = 0)
>End Function
>
>
>
>
>
>  
>

-- 
Marty Connelly
Victoria, B.C.
Canada





More information about the AccessD mailing list