1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
<?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>
|
