| <?xml version="1.0" encoding="UTF-8"?> |
| <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> |
| <!--*********************************************************** |
| * |
| * Licensed to the Apache Software Foundation (ASF) under one |
| * or more contributor license agreements. See the NOTICE file |
| * distributed with this work for additional information |
| * regarding copyright ownership. The ASF licenses this file |
| * to you under the Apache License, Version 2.0 (the |
| * "License"); you may not use this file except in compliance |
| * with the License. You may obtain a copy of the License at |
| * |
| * http://www.apache.org/licenses/LICENSE-2.0 |
| * |
| * Unless required by applicable law or agreed to in writing, |
| * software distributed under the License is distributed on an |
| * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY |
| * KIND, either express or implied. See the License for the |
| * specific language governing permissions and limitations |
| * under the License. |
| * |
| ***********************************************************--> |
| <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> |