William Hindman
wdhindman at bellsouth.net
Tue Dec 2 14:00:52 CST 2003
...ah well ...so much for that :((((
William Hindman
Government is not reason, government is not persuasion,
government is force. It is a dangerous servant." G. Washington
----- Original Message -----
From: "MartyConnelly" <martyconnelly at shaw.ca>
To: "Access Developers discussion and problem solving"
<accessd at databaseadvisors.com>
Sent: Tuesday, December 02, 2003 2:14 PM
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
>