208 lines
No EOL
6.9 KiB
XML
208 lines
No EOL
6.9 KiB
XML
<?xml version="1.0" encoding="UTF-8"?>
|
|
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
|
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="API" script:language="StarBasic">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
|
|
</script:module> |