Best way to check if RTF2.OCX is installed ??

Hi all,

I am using the RTF2 control hat Stephen Lebans provides in one of my =
apps.
I am struggling with the issue how to check if the OCX is installed =
(properly)
==> I am distributing an mde.=20

When the OCX is not installed the app just errors in a way that is very =
unclear to some users.
(The expression on open...bla bla)
I can't find a way to trap this error, display a messagebox and quit the =
app.

Code to loop the references in a startup-screen does not seem to work =
because of the missing ref...

Thanks,
Arno R

Re: Best way to check if RTF2.OCX is installed ??

Hi Arno,

I use this code to check on Autoexec macro if the RTF2 was registred :
Use : CheckRTF()

Bob


'// Start code
Option Compare Database
Option Explicit

Private Declare Function LoadLibraryRegister Lib "kernel32" Alias
"LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function CreateThreadForRegister Lib "kernel32" Alias
"CreateThread" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal
lpStartAddress As Long, ByVal lParameter As Long, ByVal dwCreationFlags As
Long, lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle
As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetProcAddressRegister Lib "kernel32" Alias
"GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibraryRegister Lib "kernel32" Alias
"FreeLibrary" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As
Long, lpExitCode As Long) As Long
Private Declare Sub ExitThread Lib "kernel32" (ByVal dwExitCode As Long)

Public Function ifRTFReference() As Boolean
'Retourne si la référence RTF est installer
On Error GoTo ErrRef

Dim i As Long
For i = 1 To References.Count
If InStr(1, References(i).FullPath, "RTF", vbTextCompare) <> 0 Then
If References(i).IsBroken = True Then
ifRTFReference = False
Else
ifRTFReference = True
End If

Exit Function
End If
Next i

Exit Function

ErrRef:
Stop

End Function

Public Function RegServer(ByVal FileName As String) As Boolean

'USAGE: PASS FULL PATH OF ACTIVE .DLL OR
'OCX YOU WANT TO REGISTER
RegServer = RegSvr32(FileName, False)
End Function

Public Function UnRegServer(ByVal FileName As String) As Boolean

'USAGE: PASS FULL PATH OF ACTIVE .DLL OR
'OCX YOU WANT TO UNREGISTER
UnRegServer = RegSvr32(FileName, True)
End Function

Private Function RegSvr32(ByVal FileName As String, bUnReg As _
Boolean) As Boolean

Dim lLib As Long
Dim lProcAddress As Long
Dim lThreadID As Long
Dim lSuccess As Long
Dim lExitCode As Long
Dim lThread As Long
Dim bAns As Boolean
Dim sPurpose As String

sPurpose = IIf(bUnReg, "DllUnregisterServer", _
"DllRegisterServer")

If Dir(FileName) = "" Then Exit Function

lLib = LoadLibraryRegister(FileName)
'could load file
If lLib = 0 Then Exit Function

lProcAddress = GetProcAddressRegister(lLib, sPurpose)

If lProcAddress = 0 Then
'Not an ActiveX Component
FreeLibraryRegister lLib
Exit Function
Else
lThread = CreateThreadForRegister(ByVal 0&, 0&, ByVal lProcAddress, ByVal
0&, 0&, lThread)
If lThread Then
lSuccess = (WaitForSingleObject(lThread, 10000) = 0)
If Not lSuccess Then
Call GetExitCodeThread(lThread, lExitCode)
Call ExitThread(lExitCode)
bAns = False
Exit Function
Else
bAns = True
End If
CloseHandle lThread
FreeLibraryRegister lLib
End If
End If
RegSvr32 = bAns
End Function

Public Function CheckRTF()
'Vérifie et enregistre le RTF dans les référence et la base de régistre
Dim PathRTF As String
PathRTF = CurrentProject.Path & "\RTF2.ocx"

'Si RT2.OCX n'est pas enregistrer
If ifRTFRegistredRTF = False Then
If Dir(PathRTF, vbArchive) <> "" Then
RegServer PathRTF
Else
MsgBox "Impossible de trouver la composante RTF," & vbCrLf &
"contacter le support technique pour plus d'information !", vbExclamation,
"Composante"
End If
End If
End Function

Public Function ifRTFRegistredRTF() As Boolean
'Vérifie si la composant RTF est enregistrer
Dim fValue As String
ReadRegistry "HKCR", "RTF2.RTF2Ctrl.1\", "", "S", "", fValue
If fValue <> "" Then
ifRTFRegistredRTF = True
Else
ifRTFRegistredRTF = False
End If
End Function

'\\ End Code




"Arno R" a écrit dans le message de
news:47f392d0$0$14781$ba620dc5@text.nova.planet.nl...
Hi all,

I am using the RTF2 control hat Stephen Lebans provides in one of my apps.
I am struggling with the issue how to check if the OCX is installed
(properly)
==> I am distributing an mde.

When the OCX is not installed the app just errors in a way that is very
unclear to some users.
(The expression on open...bla bla)
I can't find a way to trap this error, display a messagebox and quit the
app.

Code to loop the references in a startup-screen does not seem to work
because of the missing ref...

Thanks,
Arno R

Re: Best way to check if RTF2.OCX is installed ??

Hi Bob,

I tried all kind of References loops but no solution yet...

Your code looks promising but fails on the following line:
ReadRegistry "HKCR", "RTF2.RTF2Ctrl.1\", "", "S", "", fValue

I see the code for ReadRegistry is missing indeed ...
Could you post that piece of code please so I can check if it works ??

Merci,
Arno R


"Bob" schreef in bericht =
news:M7SIj.26951$ny4.30490@weber.videotron.net...
> Hi Arno,
>=20
> I use this code to check on Autoexec macro if the RTF2 was registred :
> Use : CheckRTF()
>=20
> Bob
>=20
>=20
> '// Start code
> Option Compare Database
> Option Explicit
>=20
> Private Declare Function LoadLibraryRegister Lib "kernel32" Alias=20
> "LoadLibraryA" (ByVal lpLibFileName As String) As Long
> Private Declare Function CreateThreadForRegister Lib "kernel32" Alias=20
> "CreateThread" (lpThreadAttributes As Any, ByVal dwStackSize As Long, =
ByVal=20
> lpStartAddress As Long, ByVal lParameter As Long, ByVal =
dwCreationFlags As=20
> Long, lpThreadID As Long) As Long
> Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal =
hHandle=20
> As Long, ByVal dwMilliseconds As Long) As Long
> Private Declare Function GetProcAddressRegister Lib "kernel32" Alias=20
> "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) =
As Long
> Private Declare Function FreeLibraryRegister Lib "kernel32" Alias=20
> "FreeLibrary" (ByVal hLibModule As Long) As Long
> Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As =
Long)=20
> As Long
> Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal =
hThread As=20
> Long, lpExitCode As Long) As Long
> Private Declare Sub ExitThread Lib "kernel32" (ByVal dwExitCode As =
Long)
>=20
> Public Function ifRTFReference() As Boolean
> 'Retourne si la r=E9f=E9rence RTF est installer
> On Error GoTo ErrRef
>=20
> Dim i As Long
> For i =3D 1 To References.Count
> If InStr(1, References(i).FullPath, "RTF", vbTextCompare) <> 0 Then
> If References(i).IsBroken =3D True Then
> ifRTFReference =3D False
> Else
> ifRTFReference =3D True
> End If
>=20
> Exit Function
> End If
> Next i
>=20
> Exit Function
>=20
> ErrRef:
> Stop
>=20
> End Function
>=20
> Public Function RegServer(ByVal FileName As String) As Boolean
>=20
> 'USAGE: PASS FULL PATH OF ACTIVE .DLL OR
> 'OCX YOU WANT TO REGISTER
> RegServer =3D RegSvr32(FileName, False)
> End Function
>=20
> Public Function UnRegServer(ByVal FileName As String) As Boolean
>=20
> 'USAGE: PASS FULL PATH OF ACTIVE .DLL OR
> 'OCX YOU WANT TO UNREGISTER
> UnRegServer =3D RegSvr32(FileName, True)
> End Function
>=20
> Private Function RegSvr32(ByVal FileName As String, bUnReg As _
> Boolean) As Boolean
>=20
> Dim lLib As Long
> Dim lProcAddress As Long
> Dim lThreadID As Long
> Dim lSuccess As Long
> Dim lExitCode As Long
> Dim lThread As Long
> Dim bAns As Boolean
> Dim sPurpose As String
>=20
> sPurpose =3D IIf(bUnReg, "DllUnregisterServer", _
> "DllRegisterServer")
>=20
> If Dir(FileName) =3D "" Then Exit Function
>=20
> lLib =3D LoadLibraryRegister(FileName)
> 'could load file
> If lLib =3D 0 Then Exit Function
>=20
> lProcAddress =3D GetProcAddressRegister(lLib, sPurpose)
>=20
> If lProcAddress =3D 0 Then
> 'Not an ActiveX Component
> FreeLibraryRegister lLib
> Exit Function
> Else
> lThread =3D CreateThreadForRegister(ByVal 0&, 0&, ByVal =
lProcAddress, ByVal=20
> 0&, 0&, lThread)
> If lThread Then
> lSuccess =3D (WaitForSingleObject(lThread, 10000) =3D 0)
> If Not lSuccess Then
> Call GetExitCodeThread(lThread, lExitCode)
> Call ExitThread(lExitCode)
> bAns =3D False
> Exit Function
> Else
> bAns =3D True
> End If
> CloseHandle lThread
> FreeLibraryRegister lLib
> End If
> End If
> RegSvr32 =3D bAns
> End Function
>=20
> Public Function CheckRTF()
> 'V=E9rifie et enregistre le RTF dans les r=E9f=E9rence et la base de =
r=E9gistre
> Dim PathRTF As String
> PathRTF =3D CurrentProject.Path & "\RTF2.ocx"
>=20
> 'Si RT2.OCX n'est pas enregistrer
> If ifRTFRegistredRTF =3D False Then
> If Dir(PathRTF, vbArchive) <> "" Then
> RegServer PathRTF
> Else
> MsgBox "Impossible de trouver la composante RTF," & vbCrLf &=20
> "contacter le support technique pour plus d'information !", =
vbExclamation,=20
> "Composante"
> End If
> End If
> End Function
>=20
> Public Function ifRTFRegistredRTF() As Boolean
> 'V=E9rifie si la composant RTF est enregistrer
> Dim fValue As String
> ReadRegistry "HKCR", "RTF2.RTF2Ctrl.1\", "", "S", "", fValue
> If fValue <> "" Then
> ifRTFRegistredRTF =3D True
> Else
> ifRTFRegistredRTF =3D False
> End If
> End Function
>=20
> '\\ End Code
>=20
>=20
>=20
>=20
> "Arno R" a =E9crit dans le message de=20
> news:47f392d0$0$14781$ba620dc5@text.nova.planet.nl...
> Hi all,
>=20
> I am using the RTF2 control hat Stephen Lebans provides in one of my =
apps.
> I am struggling with the issue how to check if the OCX is installed=20
> (properly)
> ==> I am distributing an mde.
>=20
> When the OCX is not installed the app just errors in a way that is =
very=20
> unclear to some users.
> (The expression on open...bla bla)
> I can't find a way to trap this error, display a messagebox and quit =
the=20
> app.
>=20
> Code to loop the references in a startup-screen does not seem to work=20
> because of the missing ref...
>=20
> Thanks,
> Arno R=20
>

Re: Best way to check if RTF2.OCX is installed ??

Sorry Arno i forget this module "modRegistry"

'// Start code
Option Explicit

Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type

Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

' Constants for Registry top-level keys
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_DYN_DATA = &H80000006
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_CLASSES_ROOT = &H80000000

' Return values
Public Const ERROR_SUCCESS = 0&
Public Const ERROR_FILE_NOT_FOUND = 2&
Public Const ERROR_MORE_DATA = 234

' RegCreateKeyEx options
Public Const REG_OPTION_NON_VOLATILE = 0

' RegCreateKeyEx Disposition
Public Const REG_CREATED_NEW_KEY = &H1
Public Const REG_OPENED_EXISTING_KEY = &H2

' Registry data types
Public Const REG_SZ = 1
Public Const REG_BINARY = 3
Public Const REG_DWORD = 4

' Registry security attributes
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4

Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, lpReserved As
Long, _
lpType As Long, lpData As Byte, lpcbData As Long) As Long

Declare Function RegQueryInfoKey Lib "advapi32.dll" _
Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As
String, _
lpcbClass As Long, lpReserved As Long, lpcSubKeys As Long, _
lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As
Long, _
lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, _
lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As
Long

Declare Function RegDeleteValue Lib "advapi32.dll" _
Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) _
As Long

Declare Function RegDeleteKey Lib "advapi32.dll" _
Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String) As Long

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

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

Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpszValueName As String, _
ByVal lpdwReserved As Long, lpdwType As Long, _
lpData As Any, lpcbData As Long) As Long

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

Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Declare Function GetPrivateProfileSection Lib "kernel32" _
Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, ByVal _
lpFileName As String) As Long

Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String,
_
ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal
lpReturnedString _
As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As
String, _
ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As
String) _
As Long

Declare Function GetPrivateProfileInt Lib "kernel32" _
Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName
_
As String) As Long

Public Function fDeleteKey(ByVal sTopKey As String, ByVal sSubKey As String,
ByVal sKeyName As String) As Long

Dim lTopKey As Long
Dim lHandle As Long
Dim lResult As Long

On Error GoTo fDeleteKeyError
lResult = 99
lTopKey = fTopKey(sTopKey)
If lTopKey = 0 Then GoTo fDeleteKeyError

lResult = RegOpenKeyEx(lTopKey, sSubKey, 0, KEY_CREATE_SUB_KEY, lHandle)
If lResult = ERROR_SUCCESS Then
lResult = RegDeleteKey(lHandle, sKeyName)
End If

If lResult = ERROR_SUCCESS Or lResult = ERROR_FILE_NOT_FOUND Then
fDeleteKey = ERROR_SUCCESS
Else
fDeleteKey = lResult
End If
Exit Function

fDeleteKeyError:
MsgBox "Unable to delete registry key.", vbExclamation, "fDeleteKey"
fDeleteKey = lResult
End Function

Public Function fDeleteValue(ByVal sTopKeyOrFile As String, ByVal
sSubKeyOrSection As String, ByVal sValueName As String) As Long

Dim lTopKey As Long
Dim lHandle As Long
Dim lResult As Long

On Error GoTo fDeleteValueError
lResult = 99
lTopKey = fTopKey(sTopKeyOrFile)
If lTopKey = 0 Then GoTo fDeleteValueError

If lTopKey = 1 Then
lResult = WritePrivateProfileString(sSubKeyOrSection, sValueName, "",
sTopKeyOrFile)
Else
lResult = RegOpenKeyEx(lTopKey, sSubKeyOrSection, 0, KEY_SET_VALUE,
lHandle)
If lResult = ERROR_SUCCESS Then
lResult = RegDeleteValue(lHandle, sValueName)
End If

If lResult = ERROR_SUCCESS Or lResult = ERROR_FILE_NOT_FOUND Then
fDeleteValue = ERROR_SUCCESS
Else
fDeleteValue = lResult
End If
End If
Exit Function

fDeleteValueError:
MsgBox "Unable to delete registry or .ini file value.", vbExclamation,
"fDeleteValue"
fDeleteValue = lResult
End Function

Public Function fEnumValue(ByVal sTopKeyOrIniFile As String, ByVal
sSubKeyOrSection As String, sValues As String) As Long

Dim lTopKey As Long
Dim lHandle As Long
Dim lResult As Long
Dim lMaxLen As Long
Dim lLenData As Long
Dim lActualLen As Long
Dim lValues As Long
Dim lIndex As Long
Dim lValueType As Long
Dim sValueName As String
Dim sValue As String
Dim bValue As Boolean
Dim tFileTime As FILETIME

On Error GoTo fEnumValueError
lResult = 99
lTopKey = fTopKey(sTopKeyOrIniFile)
If lTopKey = 0 Then GoTo fEnumValueError

If lTopKey = 1 Then
'
' Enumerate an .ini file section.
'
sValues = Space$(8192)
lResult = GetPrivateProfileSection(sSubKeyOrSection, sValues,
Len(sValues), sTopKeyOrIniFile)
Else
'
' Open the registry SubKey.
'
lResult = RegOpenKeyEx(lTopKey, sSubKeyOrSection, 0, KEY_QUERY_VALUE,
lHandle)
If lResult <> ERROR_SUCCESS Then GoTo fEnumValueError

lResult = RegQueryInfoKey(lHandle, "", 0, 0, 0, 0, 0, lValues, lLenData,
0, 0, tFileTime)
If lResult <> ERROR_SUCCESS Then GoTo fEnumValueError
lMaxLen = lLenData + 1

Do While lIndex <= lValues - 1
sValueName = Space$(lMaxLen)
lActualLen = lMaxLen
'
' Query the value's type, size and length.
'
Call RegEnumValue(lHandle, lIndex, sValueName, lActualLen, 0,
lValueType, ByVal 0, 0)
'
' Get the actual value.
'
If lValueType = REG_SZ Then
'
' String value. The first query gets the string length.
' The second gets the string value.
'
sValueName = Left$(sValueName, lActualLen)
lLenData = 0

lResult = RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, "",
lLenData)
If lResult = ERROR_MORE_DATA Then
sValue = Space$(lLenData)
lResult = RegQueryValueEx(lHandle, sValueName, 0, REG_SZ,
ByVal sValue, lLenData)
If lResult = ERROR_SUCCESS Then
sValues = sValues & sValueName & "=" & sValue
Else
GoTo fEnumValueError
End If
Else
GoTo fEnumValueError
End If
Else
'
' Boolean value.
'
lLenData = Len(bValue)
lResult = RegQueryValueEx(lHandle, sValueName, 0, 0, bValue,
lLenData)
If lResult = ERROR_SUCCESS Then
sValueName = Left$(sValueName, lActualLen)
sValues = sValues & sValueName & "=" & bValue & vbNullChar
Else
GoTo fEnumValueError
End If
End If
lIndex = lIndex + 1
Loop
sValues = sValues & vbNullChar
'
' Close the key.
'
lResult = RegCloseKey(lHandle)
fEnumValue = lResult
End If
Exit Function
'
' Error processing.
'
fEnumValueError:
MsgBox "Unable to enumerate registry or .ini file values.",
vbExclamation, "fEnumValue"
fEnumValue = lResult
End Function





Public Function fReadIniFuzzy(ByVal sIniFile As String, sSection As String,
_
ByVal sIniEntry As String, ByVal sDefault As String, sValue As
String) As Long

Dim sNextChar As String
Dim sLine As String
Dim sEntry As String
Dim sSectionName As String
Dim iLen As Integer
Dim iLocOfEq As Integer
Dim iFnum As Integer
Dim bDone As Boolean
Dim bFound As Boolean
Dim bNewSection As Boolean

On Error GoTo fReadIniFuzzyError
fReadIniFuzzy = 99
bDone = False
sValue = sDefault
sEntry = UCase$(sIniEntry)
sSection = UCase$(sSection)
iLen = Len(sSection)

iFnum = FreeFile
Open sIniFile For Input Access Read As iFnum

Line Input #iFnum, sLine
Do While Not EOF(iFnum) And Not bDone
sLine = UCase$(Trim$(sLine))
bNewSection = False
'
' See if line is a section heading.
'
If Left$(sLine, 1) = "[" Then
'
' See if section heading contains desired value.
'
sSectionName = sLine
Dim iPos As Integer
iPos = InStr(1, sLine, sSection)
If iPos > 0 Then
'
' Be sure the value is not part of a larger value.
'
sNextChar = Mid$(sLine, iPos + iLen, 1)
If sNextChar = " " Or sNextChar = "]" Then
'
' Search this section for the entry.
'
Line Input #iFnum, sLine
bFound = False
bNewSection = False
Do While Not EOF(iFnum) And Not bFound
'
' If we hit a new section, stop.
'
sLine = UCase$(Trim$(sLine))
If Left$(sLine, 1) = "[" Then
bNewSection = True
Exit Do
End If
'
' Entry must start in column 1 to avoid comment lines.
'
If InStr(1, sLine, sEntry) = 1 Then
'
' If entry found and line is not incomplete, get
value.
'
iLocOfEq = InStr(1, sLine, "=")
If iLocOfEq <> 0 Then
sValue = Mid$(sLine, iLocOfEq + 1)
sSection = Mid$(sSectionName, 2, InStr(1,
sSectionName, "]") - 2)
bFound = True
bDone = True
fReadIniFuzzy = 0
End If
End If
If Not bFound Then
Line Input #iFnum, sLine
End If
Loop
If EOF(iFnum) Then bDone = True
sSection = Mid$(sSectionName, 2, InStr(1, sSectionName,
"]") - 2)
End If
End If
End If
If Not bNewSection And Not bDone Then
Line Input #iFnum, sLine
End If
Loop
Close iFnum
Exit Function

fReadIniFuzzyError:
MsgBox "Unable to read .ini file value.", vbExclamation, "fReadIniFuzzy"
fReadIniFuzzy = 99
End Function
Public Function ReadRegistry(ByVal sTopKeyOrFile As String, ByVal
sSubKeyOrSection As String, _
ByVal sValueName As String, ByVal sValueType As String, ByVal
vDefault As Variant, _
vValue As Variant) As Long

Dim lTopKey As Long
Dim lHandle As Long
Dim lLenData As Long
Dim lResult As Long
Dim lDefault As Long
Dim sValue As String
Dim sSubKeyPath As String
Dim sDefaultStr As String
Dim bValue As Boolean

On Error GoTo fReadValueError
lResult = 99
vValue = vDefault
lTopKey = fTopKey(sTopKeyOrFile)
If lTopKey = 0 Then GoTo fReadValueError

If lTopKey = 1 Then
'
' Read the .ini file value.
'
If UCase$(sValueType) = "S" Then
lLenData = 255
sDefaultStr = vDefault
sValue = Space$(lLenData)
lResult = GetPrivateProfileString(sSubKeyOrSection, sValueName,
sDefaultStr, sValue, lLenData, sTopKeyOrFile)
vValue = Left$(sValue, lResult)
Else
lDefault = 0
lResult = GetPrivateProfileInt(sSubKeyOrSection, sValueName,
lDefault, sTopKeyOrFile)
End If
Else
'
' Open the registry SubKey.
'
lResult = RegOpenKeyEx(lTopKey, sSubKeyOrSection, 0, KEY_QUERY_VALUE,
lHandle)
If lResult <> ERROR_SUCCESS Then GoTo fReadValueError
'
' Get the actual value.
'
If UCase$(sValueType) = "S" Then
'
' String value. The first query gets the string length. The second
' gets the string value.
'
lResult = RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, "",
lLenData)
If lResult = ERROR_MORE_DATA Then
sValue = Space(lLenData)
lResult = RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, ByVal
sValue, lLenData)
End If
If lResult = ERROR_SUCCESS Then 'Remove null character.
vValue = Left$(sValue, lLenData - 1)
Else
GoTo fReadValueError
End If
Else
'
' Boolean value.
'
lLenData = Len(bValue)
lResult = RegQueryValueEx(lHandle, sValueName, 0, 0, bValue,
lLenData)
If lResult = ERROR_SUCCESS Then
vValue = bValue
Else
GoTo fReadValueError
End If
End If
'
' Close the key.
'
lResult = RegCloseKey(lHandle)
ReadRegistry = lResult
End If
Exit Function
'
' Error processing.
'
fReadValueError:
vValue = IIf(Estvide(vDefault), 0, vDefault)
End Function

Private Function fTopKey(ByVal sTopKeyOrFile As String) As Long
Dim sDir As String

' This function returns:
' - the numeric value of a top level registry key or
' - 1 if sTopKey is a valid .ini file or
' - 0 otherwise.
'
On Error GoTo fTopKeyError
fTopKey = 0
Select Case UCase$(sTopKeyOrFile)
Case "HKCU"
fTopKey = HKEY_CURRENT_USER
Case "HKLM"
fTopKey = HKEY_LOCAL_MACHINE
Case "HKU"
fTopKey = HKEY_USERS
Case "HKDD"
fTopKey = HKEY_DYN_DATA
Case "HKCC"
fTopKey = HKEY_CURRENT_CONFIG
Case "HKCR"
fTopKey = HKEY_CLASSES_ROOT
Case Else
On Error Resume Next
sDir = Dir$(sTopKeyOrFile)
If err.Number = 0 And sDir <> "" Then fTopKey = 1
End Select
Exit Function

fTopKeyError:
MsgBox "Unable to decode registry key or find .ini file.",
vbExclamation, "fTopKey"
End Function

Public Function WriteRegistry(ByVal sTopKeyOrFile As String, ByVal
sSubKeyOrSection As String, _
ByVal sValueName As String, ByVal sValueType As String, ByVal vValue
As Variant) As Long

Dim hKey As Long
Dim lTopKey As Long
Dim lOptions As Long
Dim lsamDesired As Long
Dim lHandle As Long
Dim lDisposition As Long
Dim lLenData As Long
Dim lResult As Long
Dim sClass As String
Dim sValue As String
Dim iValue As Long
Dim sSubKeyPath As String
Dim bValue As Boolean
Dim tSecurityAttributes As SECURITY_ATTRIBUTES

On Error GoTo fWriteValueError
lResult = 99
lTopKey = fTopKey(sTopKeyOrFile)
If lTopKey = 0 Then GoTo fWriteValueError

If lTopKey = 1 Then
'
' Read the .ini file value.
'
If UCase$(sValueType) = "S" Then
sValue = vValue
lResult = WritePrivateProfileString(sSubKeyOrSection, sValueName,
sValue, sTopKeyOrFile)
Else
GoTo fWriteValueError
End If
Else
sClass = ""
lOptions = REG_OPTION_NON_VOLATILE
lsamDesired = KEY_CREATE_SUB_KEY Or KEY_SET_VALUE
'
' Create the SubKey or open it if it exists. Return its handle.
' lDisposition will be REG_CREATED_NEW_KEY if the key did not exist.
'
lResult = RegCreateKeyEx(lTopKey, sSubKeyOrSection, 0, sClass, lOptions,
_
lsamDesired, tSecurityAttributes, lHandle, lDisposition)
If lResult <> ERROR_SUCCESS Then GoTo fWriteValueError
'
' Set the actual value.
'
If UCase$(sValueType) = "S" Then 'String value.
sValue = vValue
lLenData = Len(sValue) + 1
lResult = RegSetValueEx(lHandle, sValueName, 0, REG_SZ, ByVal
sValue, lLenData)
ElseIf UCase$(sValueType) = "B" Then 'Boolean value.
bValue = vValue
lLenData = Len(bValue)
lResult = RegSetValueEx(lHandle, sValueName, 0, REG_BINARY, bValue,
lLenData)
ElseIf UCase$(sValueType) = "D" Then 'Dword
sValue = vValue
lLenData = Len(sValue) + 1
lResult = RegSetValueEx(lHandle, sValueName, 0, REG_DWORD, sValue,
lLenData + 1)
End If
'
' Close the key.
'
If lResult = ERROR_SUCCESS Then
lResult = RegCloseKey(lHandle)
WriteRegistry = lResult
Exit Function
End If
End If
Exit Function
'
' Error processing.
'
fWriteValueError:
MsgBox "Unable to write registry or .ini file value.", vbExclamation,
"fWriteValue"
WriteRegistry = lResult
End Function

'\\ End code

Re: Best way to check if RTF2.OCX is installed ??

Thanks Bob. It works now !!

But I had to change the line
vValue =3D IIf(Estvide(vDefault), 0, vDefault)
to
vValue =3D vDefault to get it working

So one more question:
I don't have the function EstVide() here.
What is this function about ??

Arno R



"Bob" schreef in bericht =
news:n1UIj.13173$0g4.36230@wagner.videotron.net...
> Sorry Arno i forget this module "modRegistry"
>=20
> '// Start code
> Option Explicit
>=20
> Type SECURITY_ATTRIBUTES
> nLength As Long
> lpSecurityDescriptor As Long
> bInheritHandle As Boolean
> End Type
>=20
> Type FILETIME
> dwLowDateTime As Long
> dwHighDateTime As Long
> End Type
>=20
> ' Constants for Registry top-level keys
> Public Const HKEY_CURRENT_USER =3D &H80000001
> Public Const HKEY_LOCAL_MACHINE =3D &H80000002
> Public Const HKEY_USERS =3D &H80000003
> Public Const HKEY_DYN_DATA =3D &H80000006
> Public Const HKEY_CURRENT_CONFIG =3D &H80000005
> Public Const HKEY_CLASSES_ROOT =3D &H80000000
>=20
> ' Return values
> Public Const ERROR_SUCCESS =3D 0&
> Public Const ERROR_FILE_NOT_FOUND =3D 2&
> Public Const ERROR_MORE_DATA =3D 234
>=20
> ' RegCreateKeyEx options
> Public Const REG_OPTION_NON_VOLATILE =3D 0
>=20
> ' RegCreateKeyEx Disposition
> Public Const REG_CREATED_NEW_KEY =3D &H1
> Public Const REG_OPENED_EXISTING_KEY =3D &H2
>=20
> ' Registry data types
> Public Const REG_SZ =3D 1
> Public Const REG_BINARY =3D 3
> Public Const REG_DWORD =3D 4
>=20
> ' Registry security attributes
> Public Const KEY_QUERY_VALUE =3D &H1
> Public Const KEY_SET_VALUE =3D &H2
> Public Const KEY_CREATE_SUB_KEY =3D &H4
>=20
> Declare Function RegEnumValue Lib "advapi32.dll" _
> Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As =
Long, _
> ByVal lpValueName As String, lpcbValueName As Long, lpReserved =
As=20
> Long, _
> lpType As Long, lpData As Byte, lpcbData As Long) As Long
>=20
> Declare Function RegQueryInfoKey Lib "advapi32.dll" _
> Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As=20
> String, _
> lpcbClass As Long, lpReserved As Long, lpcSubKeys As Long, _
> lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As =

> Long, _
> lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, _
> lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) =
As=20
> Long
>=20
> Declare Function RegDeleteValue Lib "advapi32.dll" _
> Alias "RegDeleteValueA" _
> (ByVal hKey As Long, ByVal lpValueName As String) _
> As Long
>=20
> Declare Function RegDeleteKey Lib "advapi32.dll" _
> Alias "RegDeleteKeyA" _
> (ByVal hKey As Long, ByVal lpSubKey As String) As Long
>=20
> 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
>=20
> 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
>=20
> Declare Function RegQueryValueEx Lib "advapi32.dll" _
> Alias "RegQueryValueExA" _
> (ByVal hKey As Long, ByVal lpszValueName As String, _
> ByVal lpdwReserved As Long, lpdwType As Long, _
> lpData As Any, lpcbData As Long) As Long
>=20
> 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
>=20
> Declare Function RegCloseKey Lib "advapi32.dll" _
> (ByVal hKey As Long) As Long
>=20
> Declare Function GetPrivateProfileSection Lib "kernel32" _
> Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, _
> ByVal lpReturnedString As String, ByVal nSize As Long, ByVal _
> lpFileName As String) As Long
>=20
> Declare Function GetPrivateProfileString Lib "kernel32" _
> Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As =
String,=20
> _
> ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal=20
> lpReturnedString _
> As String, ByVal nSize As Long, ByVal lpFileName As String) As =
Long
>=20
> Declare Function WritePrivateProfileString Lib "kernel32" _
> Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As=20
> String, _
> ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName =
As=20
> String) _
> As Long
>=20
> Declare Function GetPrivateProfileInt Lib "kernel32" _
> Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As =
String, _
> ByVal lpKeyName As String, ByVal nDefault As Long, ByVal =
lpFileName=20
> _
> As String) As Long
>=20
> Public Function fDeleteKey(ByVal sTopKey As String, ByVal sSubKey As =
String,=20
> ByVal sKeyName As String) As Long
>=20
> Dim lTopKey As Long
> Dim lHandle As Long
> Dim lResult As Long
>=20
> On Error GoTo fDeleteKeyError
> lResult =3D 99
> lTopKey =3D fTopKey(sTopKey)
> If lTopKey =3D 0 Then GoTo fDeleteKeyError
>=20
> lResult =3D RegOpenKeyEx(lTopKey, sSubKey, 0, KEY_CREATE_SUB_KEY, =
lHandle)
> If lResult =3D ERROR_SUCCESS Then
> lResult =3D RegDeleteKey(lHandle, sKeyName)
> End If
>=20
> If lResult =3D ERROR_SUCCESS Or lResult =3D ERROR_FILE_NOT_FOUND Then
> fDeleteKey =3D ERROR_SUCCESS
> Else
> fDeleteKey =3D lResult
> End If
> Exit Function
>=20
> fDeleteKeyError:
> MsgBox "Unable to delete registry key.", vbExclamation, =
"fDeleteKey"
> fDeleteKey =3D lResult
> End Function
>=20
> Public Function fDeleteValue(ByVal sTopKeyOrFile As String, ByVal=20
> sSubKeyOrSection As String, ByVal sValueName As String) As Long
>=20
> Dim lTopKey As Long
> Dim lHandle As Long
> Dim lResult As Long
>=20
> On Error GoTo fDeleteValueError
> lResult =3D 99
> lTopKey =3D fTopKey(sTopKeyOrFile)
> If lTopKey =3D 0 Then GoTo fDeleteValueError
>=20
> If lTopKey =3D 1 Then
> lResult =3D WritePrivateProfileString(sSubKeyOrSection, sValueName, =
"",=20
> sTopKeyOrFile)
> Else
> lResult =3D RegOpenKeyEx(lTopKey, sSubKeyOrSection, 0, =
KEY_SET_VALUE,=20
> lHandle)
> If lResult =3D ERROR_SUCCESS Then
> lResult =3D RegDeleteValue(lHandle, sValueName)
> End If
>=20
> If lResult =3D ERROR_SUCCESS Or lResult =3D ERROR_FILE_NOT_FOUND =
Then
> fDeleteValue =3D ERROR_SUCCESS
> Else
> fDeleteValue =3D lResult
> End If
> End If
> Exit Function
>=20
> fDeleteValueError:
> MsgBox "Unable to delete registry or .ini file value.", =
vbExclamation,=20
> "fDeleteValue"
> fDeleteValue =3D lResult
> End Function
>=20
> Public Function fEnumValue(ByVal sTopKeyOrIniFile As String, ByVal=20
> sSubKeyOrSection As String, sValues As String) As Long
>=20
> Dim lTopKey As Long
> Dim lHandle As Long
> Dim lResult As Long
> Dim lMaxLen As Long
> Dim lLenData As Long
> Dim lActualLen As Long
> Dim lValues As Long
> Dim lIndex As Long
> Dim lValueType As Long
> Dim sValueName As String
> Dim sValue As String
> Dim bValue As Boolean
> Dim tFileTime As FILETIME
>=20
> On Error GoTo fEnumValueError
> lResult =3D 99
> lTopKey =3D fTopKey(sTopKeyOrIniFile)
> If lTopKey =3D 0 Then GoTo fEnumValueError
>=20
> If lTopKey =3D 1 Then
> '
> ' Enumerate an .ini file section.
> '
> sValues =3D Space$(8192)
> lResult =3D GetPrivateProfileSection(sSubKeyOrSection, sValues,=20
> Len(sValues), sTopKeyOrIniFile)
> Else
> '
> ' Open the registry SubKey.
> '
> lResult =3D RegOpenKeyEx(lTopKey, sSubKeyOrSection, 0, =
KEY_QUERY_VALUE,=20
> lHandle)
> If lResult <> ERROR_SUCCESS Then GoTo fEnumValueError
>=20
> lResult =3D RegQueryInfoKey(lHandle, "", 0, 0, 0, 0, 0, lValues, =
lLenData,=20
> 0, 0, tFileTime)
> If lResult <> ERROR_SUCCESS Then GoTo fEnumValueError
> lMaxLen =3D lLenData + 1
>=20
> Do While lIndex <=3D lValues - 1
> sValueName =3D Space$(lMaxLen)
> lActualLen =3D lMaxLen
> '
> ' Query the value's type, size and length.
> '
> Call RegEnumValue(lHandle, lIndex, sValueName, lActualLen, 0,=20
> lValueType, ByVal 0, 0)
> '
> ' Get the actual value.
> '
> If lValueType =3D REG_SZ Then
> '
> ' String value. The first query gets the string length.
> ' The second gets the string value.
> '
> sValueName =3D Left$(sValueName, lActualLen)
> lLenData =3D 0
>=20
> lResult =3D RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, =
"",=20
> lLenData)
> If lResult =3D ERROR_MORE_DATA Then
> sValue =3D Space$(lLenData)
> lResult =3D RegQueryValueEx(lHandle, sValueName, 0, =
REG_SZ,=20
> ByVal sValue, lLenData)
> If lResult =3D ERROR_SUCCESS Then
> sValues =3D sValues & sValueName & "=3D" & sValue
> Else
> GoTo fEnumValueError
> End If
> Else
> GoTo fEnumValueError
> End If
> Else
> '
> ' Boolean value.
> '
> lLenData =3D Len(bValue)
> lResult =3D RegQueryValueEx(lHandle, sValueName, 0, 0, =
bValue,=20
> lLenData)
> If lResult =3D ERROR_SUCCESS Then
> sValueName =3D Left$(sValueName, lActualLen)
> sValues =3D sValues & sValueName & "=3D" & bValue & =
vbNullChar
> Else
> GoTo fEnumValueError
> End If
> End If
> lIndex =3D lIndex + 1
> Loop
> sValues =3D sValues & vbNullChar
> '
> ' Close the key.
> '
> lResult =3D RegCloseKey(lHandle)
> fEnumValue =3D lResult
> End If
> Exit Function
> '
> ' Error processing.
> '
> fEnumValueError:
> MsgBox "Unable to enumerate registry or .ini file values.",=20
> vbExclamation, "fEnumValue"
> fEnumValue =3D lResult
> End Function
>=20
>=20
>=20
>=20
>=20
> Public Function fReadIniFuzzy(ByVal sIniFile As String, sSection As =
String,=20
> _
> ByVal sIniEntry As String, ByVal sDefault As String, sValue =
As=20
> String) As Long
>=20
> Dim sNextChar As String
> Dim sLine As String
> Dim sEntry As String
> Dim sSectionName As String
> Dim iLen As Integer
> Dim iLocOfEq As Integer
> Dim iFnum As Integer
> Dim bDone As Boolean
> Dim bFound As Boolean
> Dim bNewSection As Boolean
>=20
> On Error GoTo fReadIniFuzzyError
> fReadIniFuzzy =3D 99
> bDone =3D False
> sValue =3D sDefault
> sEntry =3D UCase$(sIniEntry)
> sSection =3D UCase$(sSection)
> iLen =3D Len(sSection)
>=20
> iFnum =3D FreeFile
> Open sIniFile For Input Access Read As iFnum
>=20
> Line Input #iFnum, sLine
> Do While Not EOF(iFnum) And Not bDone
> sLine =3D UCase$(Trim$(sLine))
> bNewSection =3D False
> '
> ' See if line is a section heading.
> '
> If Left$(sLine, 1) =3D "[" Then
> '
> ' See if section heading contains desired value.
> '
> sSectionName =3D sLine
> Dim iPos As Integer
> iPos =3D InStr(1, sLine, sSection)
> If iPos > 0 Then
> '
> ' Be sure the value is not part of a larger value.
> '
> sNextChar =3D Mid$(sLine, iPos + iLen, 1)
> If sNextChar =3D " " Or sNextChar =3D "]" Then
> '
> ' Search this section for the entry.
> '
> Line Input #iFnum, sLine
> bFound =3D False
> bNewSection =3D False
> Do While Not EOF(iFnum) And Not bFound
> '
> ' If we hit a new section, stop.
> '
> sLine =3D UCase$(Trim$(sLine))
> If Left$(sLine, 1) =3D "[" Then
> bNewSection =3D True
> Exit Do
> End If
> '
> ' Entry must start in column 1 to avoid comment =
lines.
> '
> If InStr(1, sLine, sEntry) =3D 1 Then
> '
> ' If entry found and line is not incomplete, =
get=20
> value.
> '
> iLocOfEq =3D InStr(1, sLine, "=3D")
> If iLocOfEq <> 0 Then
> sValue =3D Mid$(sLine, iLocOfEq + 1)
> sSection =3D Mid$(sSectionName, 2, InStr(1, =

> sSectionName, "]") - 2)
> bFound =3D True
> bDone =3D True
> fReadIniFuzzy =3D 0
> End If
> End If
> If Not bFound Then
> Line Input #iFnum, sLine
> End If
> Loop
> If EOF(iFnum) Then bDone =3D True
> sSection =3D Mid$(sSectionName, 2, InStr(1, =
sSectionName,=20
> "]") - 2)
> End If
> End If
> End If
> If Not bNewSection And Not bDone Then
> Line Input #iFnum, sLine
> End If
> Loop
> Close iFnum
> Exit Function
>=20
> fReadIniFuzzyError:
> MsgBox "Unable to read .ini file value.", vbExclamation, =
"fReadIniFuzzy"
> fReadIniFuzzy =3D 99
> End Function
> Public Function ReadRegistry(ByVal sTopKeyOrFile As String, ByVal=20
> sSubKeyOrSection As String, _
> ByVal sValueName As String, ByVal sValueType As String, ByVal=20
> vDefault As Variant, _
> vValue As Variant) As Long
>=20
> Dim lTopKey As Long
> Dim lHandle As Long
> Dim lLenData As Long
> Dim lResult As Long
> Dim lDefault As Long
> Dim sValue As String
> Dim sSubKeyPath As String
> Dim sDefaultStr As String
> Dim bValue As Boolean
>=20
> On Error GoTo fReadValueError
> lResult =3D 99
> vValue =3D vDefault
> lTopKey =3D fTopKey(sTopKeyOrFile)
> If lTopKey =3D 0 Then GoTo fReadValueError
>=20
> If lTopKey =3D 1 Then
> '
> ' Read the .ini file value.
> '
> If UCase$(sValueType) =3D "S" Then
> lLenData =3D 255
> sDefaultStr =3D vDefault
> sValue =3D Space$(lLenData)
> lResult =3D GetPrivateProfileString(sSubKeyOrSection, =
sValueName,=20
> sDefaultStr, sValue, lLenData, sTopKeyOrFile)
> vValue =3D Left$(sValue, lResult)
> Else
> lDefault =3D 0
> lResult =3D GetPrivateProfileInt(sSubKeyOrSection, sValueName,=20
> lDefault, sTopKeyOrFile)
> End If
> Else
> '
> ' Open the registry SubKey.
> '
> lResult =3D RegOpenKeyEx(lTopKey, sSubKeyOrSection, 0, =
KEY_QUERY_VALUE,=20
> lHandle)
> If lResult <> ERROR_SUCCESS Then GoTo fReadValueError
> '
> ' Get the actual value.
> '
> If UCase$(sValueType) =3D "S" Then
> '
> ' String value. The first query gets the string length. The =
second
> ' gets the string value.
> '
> lResult =3D RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, "", =

> lLenData)
> If lResult =3D ERROR_MORE_DATA Then
> sValue =3D Space(lLenData)
> lResult =3D RegQueryValueEx(lHandle, sValueName, 0, REG_SZ, =
ByVal=20
> sValue, lLenData)
> End If
> If lResult =3D ERROR_SUCCESS Then 'Remove null character.
> vValue =3D Left$(sValue, lLenData - 1)
> Else
> GoTo fReadValueError
> End If
> Else
> '
> ' Boolean value.
> '
> lLenData =3D Len(bValue)
> lResult =3D RegQueryValueEx(lHandle, sValueName, 0, 0, bValue,=20
> lLenData)
> If lResult =3D ERROR_SUCCESS Then
> vValue =3D bValue
> Else
> GoTo fReadValueError
> End If
> End If
> '
> ' Close the key.
> '
> lResult =3D RegCloseKey(lHandle)
> ReadRegistry =3D lResult
> End If
> Exit Function
> '
> ' Error processing.
> '
> fReadValueError:
> vValue =3D IIf(Estvide(vDefault), 0, vDefault)
> End Function
>=20
> Private Function fTopKey(ByVal sTopKeyOrFile As String) As Long
> Dim sDir As String
>=20
> ' This function returns:
> ' - the numeric value of a top level registry key or
> ' - 1 if sTopKey is a valid .ini file or
> ' - 0 otherwise.
> '
> On Error GoTo fTopKeyError
> fTopKey =3D 0
> Select Case UCase$(sTopKeyOrFile)
> Case "HKCU"
> fTopKey =3D HKEY_CURRENT_USER
> Case "HKLM"
> fTopKey =3D HKEY_LOCAL_MACHINE
> Case "HKU"
> fTopKey =3D HKEY_USERS
> Case "HKDD"
> fTopKey =3D HKEY_DYN_DATA
> Case "HKCC"
> fTopKey =3D HKEY_CURRENT_CONFIG
> Case "HKCR"
> fTopKey =3D HKEY_CLASSES_ROOT
> Case Else
> On Error Resume Next
> sDir =3D Dir$(sTopKeyOrFile)
> If err.Number =3D 0 And sDir <> "" Then fTopKey =3D 1
> End Select
> Exit Function
>=20
> fTopKeyError:
> MsgBox "Unable to decode registry key or find .ini file.",=20
> vbExclamation, "fTopKey"
> End Function
>=20
> Public Function WriteRegistry(ByVal sTopKeyOrFile As String, ByVal=20
> sSubKeyOrSection As String, _
> ByVal sValueName As String, ByVal sValueType As String, ByVal =
vValue=20
> As Variant) As Long
>=20
> Dim hKey As Long
> Dim lTopKey As Long
> Dim lOptions As Long
> Dim lsamDesired As Long
> Dim lHandle As Long
> Dim lDisposition As Long
> Dim lLenData As Long
> Dim lResult As Long
> Dim sClass As String
> Dim sValue As String
> Dim iValue As Long
> Dim sSubKeyPath As String
> Dim bValue As Boolean
> Dim tSecurityAttributes As SECURITY_ATTRIBUTES
>=20
> On Error GoTo fWriteValueError
> lResult =3D 99
> lTopKey =3D fTopKey(sTopKeyOrFile)
> If lTopKey =3D 0 Then GoTo fWriteValueError
>=20
> If lTopKey =3D 1 Then
> '
> ' Read the .ini file value.
> '
> If UCase$(sValueType) =3D "S" Then
> sValue =3D vValue
> lResult =3D WritePrivateProfileString(sSubKeyOrSection, =
sValueName,=20
> sValue, sTopKeyOrFile)
> Else
> GoTo fWriteValueError
> End If
> Else
> sClass =3D ""
> lOptions =3D REG_OPTION_NON_VOLATILE
> lsamDesired =3D KEY_CREATE_SUB_KEY Or KEY_SET_VALUE
> '
> ' Create the SubKey or open it if it exists. Return its handle.
> ' lDisposition will be REG_CREATED_NEW_KEY if the key did not =
exist.
> '
> lResult =3D RegCreateKeyEx(lTopKey, sSubKeyOrSection, 0, sClass, =
lOptions,=20
> _
> lsamDesired, tSecurityAttributes, lHandle, =
lDisposition)
> If lResult <> ERROR_SUCCESS Then GoTo fWriteValueError
> '
> ' Set the actual value.
> '
> If UCase$(sValueType) =3D "S" Then 'String value.
> sValue =3D vValue
> lLenData =3D Len(sValue) + 1
> lResult =3D RegSetValueEx(lHandle, sValueName, 0, REG_SZ, ByVal =

> sValue, lLenData)
> ElseIf UCase$(sValueType) =3D "B" Then 'Boolean value.
> bValue =3D vValue
> lLenData =3D Len(bValue)
> lResult =3D RegSetValueEx(lHandle, sValueName, 0, REG_BINARY, =
bValue,=20
> lLenData)
> ElseIf UCase$(sValueType) =3D "D" Then 'Dword
> sValue =3D vValue
> lLenData =3D Len(sValue) + 1
> lResult =3D RegSetValueEx(lHandle, sValueName, 0, REG_DWORD, =
sValue,=20
> lLenData + 1)
> End If
> '
> ' Close the key.
> '
> If lResult =3D ERROR_SUCCESS Then
> lResult =3D RegCloseKey(lHandle)
> WriteRegistry =3D lResult
> Exit Function
> End If
> End If
> Exit Function
> '
> ' Error processing.
> '
> fWriteValueError:
> MsgBox "Unable to write registry or .ini file value.", =
vbExclamation,=20
> "fWriteValue"
> WriteRegistry =3D lResult
> End Function
>=20
> '\\ End code
>=20
>=20
>=20
>=20
>

Re: Best way to check if RTF2.OCX is installed ??

Hi Arno.

The Function "EstVide" is like IsNull


Best regards

Bob