A Unicode string would have every other character being the ANSI
string character followed by a null string (0x00). You can get that as
a Variant value and use the Replace function to get rid of the nulls
to convert it to a string value: strResult = Replace(1, varResult,
Chr(0)). The ANSI string you want to write would then be converted
into Unicode in the reverse way, by adding 0x00 after each character
in the original string.
Here's some code I used to write some strings as Outlook categories,
which are Unicode in Outlook 2002 or later. I'll only include one
category string to keep the example short. This example hard codes the
path for Outlook 2002 categories, it would be different for Outlook
2003. Terminating the Unicode string is a double null (0x0000).
Public Sub SetMasterCategoryList()
Dim astrCategories(0 To 15) As String 'example only uses 1
Dim strCategoriesPath As String
Dim strCategories As String
Dim varCategories As Variant
Dim lLBound As Long
Dim lUBound As Long
Dim i As Long
Dim j As Long
Dim blnResult As Boolean
On Error Resume Next
strCategoriesPath =
"\Software\Microsoft\Office\10.0\Outlook\Categories"
astrCategories(0) = "Academic"
'and so on
lLBound = LBound(astrCategories)
lUBound = UBound(astrCategories)
strCategories = ""
For i = lLBound To lUBound
For j = 1 To Len(astrCategories(i))
varCategories = varCategories & Mid(astrCategories(i), j, 1) &
Chr(0)
Next j
varCategories = varCategories & ";" & Chr(0)
Next i
varCategories = varCategories & Chr(0) & Chr(0)
blnResult = basRegistry.SetKeyValue(HKEY_CURRENT_USER, _
strCategoriesPath, "MasterList", varCategories, REG_BINARY)
End Sub
'In basRegistry:
Public Const HKEY_CURRENT_USER = &H80000001
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const REG_BINARY As Long = 3
'Error codes
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_ALL_ACCESS = &H3F
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Declare Function OSRegOpenKey Lib "advapi32" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpszSubKey As String, 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 String, ByVal dwOptions _
As Long, ByVal samDesired As Long, lpSecurityAttributes _
As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long)
As Long
Private Declare Function RegSetValueExBinary Lib "advapi32.dll" Alias
_
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias
_
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long
Declare Function RegQueryValueExBinary Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
String, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
Dim cch As Long
Dim lRC As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
' Determine the size and type of data to be read
lRC = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lRC <> ERROR_NONE Then Error 5
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lRC = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue,
cch)
If lRC = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If
' For DWORDS
Case REG_DWORD:
lRC = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue,
cch)
If lRC = ERROR_NONE Then vValue = lValue
' For BINARY
Case REG_BINARY:
lRC = RegQueryValueExBinary(lhKey, szValueName, 0&, lType, lValue,
cch)
If lRC = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lRC = -1
End Select
QueryValueExExit:
QueryValueEx = lRC
Err.Clear
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
Public Function GetKeyValueEx(lKey As Long, sKeyName As String, _
sValueName As String) As Variant
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim vValue As Variant 'setting of queried value
On Error GoTo GetKeyValue_Error
lRetVal = OSRegOpenKey(lKey, sKeyName, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
If Len(vValue) Then 'Trim null
If Right$(vValue, 1) = Chr$(0) Then
vValue = Left$(vValue, Len(vValue) - 1)
End If
End If
GetKeyValueEx = vValue
RegCloseKey (hKey)
GetKeyValue_Exit:
Err.Clear
Exit Function
GetKeyValue_Error:
GetKeyValueEx = ""
Resume GetKeyValue_Exit
End Function
Private Function SetValueEx(ByVal hKey As Long, sValueName As String,
_
lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
On Error Resume Next
Select Case lType
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType,
sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType,
lValue, 4)
Case REG_BINARY
SetValueEx = RegSetValueExBinary(hKey, sValueName, 0&, lType,
vValue, Len(vValue))
End Select
End Function
Public Function SetKeyValue(lKey As Long, sKeyName As String, _
sValueName As String, vValueSetting As Variant, lValueType As Long)
As Boolean
Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key
Dim SA As SECURITY_ATTRIBUTES
On Error GoTo SetKeyValue_Error
If Left$(sKeyName, 1) = "\" Then
sKeyName = Mid$(sKeyName, 2)
ElseIf sKeyName = "" Then 'can't have blank key name
SetKeyValue = False
Exit Function
End If
lRetVal = RegCreateKeyEx(lKey, sKeyName, 0, vbNull, 0, _
KEY_ALL_ACCESS, SA, hKey, 0)
If lRetVal = ERROR_NONE Then
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
If lRetVal = ERROR_NONE Then
SetKeyValue = True
Else
SetKeyValue = False
End If
Else
SetKeyValue = False
End If
RegCloseKey (hKey)
SetKeyValue_Exit:
Exit Function
SetKeyValue_Error:
Err.Clear
SetKeyValue = False
End Function
