Charlotte Foust
cfoust at infostatsystems.com
Tue Dec 2 15:16:15 CST 2003
Don't blame Microsoft for the way area codes are allocated around the
globe. They don't have *quite* that much pull ... Yet. <VBG> I ran
into this issue years ago when I worked for a company that handled event
registration and discovered that area codes and even country codes
aren't quite the indicator of country that you might expect.
Charlotte Foust
-----Original Message-----
From: MartyConnelly [mailto:martyconnelly at shaw.ca]
Sent: Tuesday, December 02, 2003 11:15 AM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Registry tweaks
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
_______________________________________________
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com