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 RegQueryValueExString 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 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 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 Declare Function RegCloseKeyA Lib "advapi32.dll" Alias "RegCloseKey" _ (ByVal hKey As Long) As Long Public Const HKEY_CLASSES_ROOT = &H80000000 Public Const HKEY_CURRENT_USER = &H80000001 Public Const HKEY_LOCAL_MACHINE = &H80000002 Public Const HKEY_USERS = &H80000003 Public Const KEY_ALL_ACCESS = &H3F Public Const REG_OPTION_NON_VOLATILE = 0 Public Const REG_SZ As Long = 1 Public Const REG_DWORD As Long = 4 Public Const ERROR_NONE = 0 Public Const ERROR_BADDB = 1 Public Const ERROR_BADKEY = 2 Public Const ERROR_CANTOPEN = 3 Public Const ERROR_CANTREAD = 4 Public Const ERROR_CANTWRITE = 5 Public Const ERROR_OUTOFMEMORY = 6 Public Const ERROR_INVALID_PARAMETER = 7 Public Const ERROR_ACCESS_DENIED = 8 Public Const ERROR_INVALID_PARAMETERS = 87 Public Const ERROR_NO_MORE_ITEMS = 259 'Public Const KEY_READ = &H20019 Function OpenRegKey(lBaseKey As Long, sKeyName As String) As Variant Dim LocKeyValue Dim hKey as Long Dim lRetValue as Long lRetValue = RegOpenKeyEx(lBaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey) ' lRetValue = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Outlook Express\5.0\Default Settings", "Revocation Checking") If hKey <> 0 Then RegCloseKeyA (hKey) End If OpenRegKey() = lRetValue End Function Function GetDefaultPath(CurOffice as Integer) As String Dim sPath as String Dim Index as Integer Select Case Wizardmode Case SBMICROSOFTMODE Index = Applications(CurOffice,SBAPPLKEY) If GetGUIType = 1 Then ' Windows sPath = QueryValue(HKEY_LOCAL_MACHINE, sKeyName(Index), sValueName(Index)) Else sPath = "" End If If sPath = "" Then sPath = SOWorkPath End If GetDefaultPath = sPath Case SBXMLMODE GetDefaultPath = SOWorkPath End Select End Function Function GetTemplateDefaultPath(Index as Integer) As String Dim sLocTemplatePath as String Dim sLocProgrampath as String Dim Progstring as String Dim PathList()as String Dim Maxindex as Integer Dim OldsLocTemplatePath Dim sTemplateKeyName as String Dim sTemplateValueName as String On Local Error Goto NOVAlIDSYSTEMPATH Select Case WizardMode Case SBMICROSOFTMODE If GetGUIType = 1 Then ' Windows ' Template directory of Office 97 sTemplateKeyName = "Software\Microsoft\Office\8.0\Common\FileNew\LocalTemplates" sTemplateValueName = "" sLocTemplatePath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName) If sLocTemplatePath = "" Then ' Retrieve the template directory of Office 2000 ' Unfortunately there is no existing note about the template directory in ' the whole registry. ' Programdirectory of Office 2000 sTemplateKeyName = "Software\Microsoft\Office\9.0\Common\InstallRoot" sTemplateValueName = "Path" sLocProgrampath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName) If sLocProgrampath <> "" Then If Right(sLocProgrampath, 1) <> "\" Then sLocProgrampath = sLocProgrampath & "\" End If PathList() = ArrayoutofString(sLocProgrampath,"\",Maxindex) Progstring = "\" & PathList(Maxindex-1) & "\" OldsLocTemplatePath = DeleteStr(sLocProgramPath,Progstring) sLocTemplatePath = OldsLocTemplatePath & "\" & "Templates" ' Does this subdirectory "templates" exist at all If oUcb.Exists(sLocTemplatePath) Then ' If Not the main directory of the office is the base sLocTemplatePath = OldsLocTemplatePath End If Else sLocTemplatePath = SOWorkPath End If End If GetTemplateDefaultPath = ConvertToUrl(sLocTemplatePath) Else GetTemplateDefaultPath = SOWorkPath End If Case SBXMLMODE If Index = 3 Then ' Helper Application with no templates GetTemplateDefaultPath = SOWorkPath Else GetTemplateDefaultPath = SOTemplatePath End If End Select NOVALIDSYSTEMPATH: If Err <> 0 Then GetTemplateDefaultPath() = SOWorkPath Resume ONITGOES ONITGOES: End If End Function Function QueryValueEx(ByVal lhKey, ByVal szValueName As String, vValue As String) As Long Dim cch As Long Dim lrc As Long Dim lType As Long Dim lValue As Long Dim sValue As String Dim Empty On Error GoTo QueryValueExError lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch) If lrc <> ERROR_NONE Then Error 5 Select Case lType 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 Case REG_DWORD: lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch) If lrc = ERROR_NONE Then vValue = lValue End If Case Else lrc = -1 End Select QueryValueExExit: QueryValueEx = lrc Exit Function QueryValueExError: Resume QueryValueExExit End Function Function QueryValue(BaseKey As Long, sKeyName As String, sValueName As String) As Variant Dim lRetVal As Long ' Returnvalue API-Call Dim hKey As Long ' Onen key handle Dim vValue As String ' Key value lRetVal = RegOpenKeyEx(BaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey) lRetVal = QueryValueEx(hKey, sValueName, vValue) RegCloseKeyA (hKey) QueryValue = vValue End Function