MartyConnelly
martyconnelly at shaw.ca
Mon Dec 1 20:38:47 CST 2003
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