home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 April / PCWorld_2003-04_cd.bin / Software / Komercni / openoffice / f_0269 / API.xba next >
Extensible Markup Language  |  2002-02-19  |  7KB  |  201 lines
  1. <?xml version="1.0" encoding="UTF-8"?>
  2. <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
  3. <script:module xmlns:script="http://openoffice.org/2000/script" script:name="API" script:language="StarBasic">Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
  4.  (ByVal hKey As Long, _
  5.   ByVal lpSubKey As String, _
  6.   ByVal ulOptions As Long, _
  7.   ByVal samDesired As Long, _
  8.   phkResult As Long) As Long
  9.  
  10. Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _
  11.  (ByVal hKey As Long, _
  12.   ByVal lpValueName As String, _
  13.   ByVal lpReserved As Long, _
  14.   lpType As Long, _
  15.   lpData As String, _
  16.   lpcbData As Long) As Long
  17.  
  18. Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" _
  19.  (ByVal hKey As Long, _
  20.   ByVal lpValueName As String, _
  21.   ByVal lpReserved As Long, _
  22.   lpType As Long, _
  23.   lpData As Long, _
  24.   lpcbData As Long) As Long
  25.  
  26. Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" _
  27.  (ByVal hKey As Long, _
  28.   ByVal lpValueName As String, _
  29.   ByVal lpReserved As Long, _
  30.   lpType As Long, _
  31.   ByVal lpData As Long, _
  32.   lpcbData As Long) As Long
  33.  
  34. Declare Function RegCloseKeyA Lib "advapi32.dll" Alias "RegCloseKey" _
  35.  (ByVal hKey As Long) As Long
  36.  
  37.  
  38. Public Const HKEY_CLASSES_ROOT = &H80000000
  39. Public Const HKEY_CURRENT_USER = &H80000001
  40. Public Const HKEY_LOCAL_MACHINE = &H80000002
  41. Public Const HKEY_USERS = &H80000003
  42. Public Const KEY_ALL_ACCESS = &H3F
  43. Public Const REG_OPTION_NON_VOLATILE = 0
  44. Public Const REG_SZ As Long = 1
  45. Public Const REG_DWORD As Long = 4
  46. Public Const ERROR_NONE = 0
  47. Public Const ERROR_BADDB = 1
  48. Public Const ERROR_BADKEY = 2
  49. Public Const ERROR_CANTOPEN = 3
  50. Public Const ERROR_CANTREAD = 4
  51. Public Const ERROR_CANTWRITE = 5
  52. Public Const ERROR_OUTOFMEMORY = 6
  53. Public Const ERROR_INVALID_PARAMETER = 7
  54. Public Const ERROR_ACCESS_DENIED = 8
  55. Public Const ERROR_INVALID_PARAMETERS = 87
  56. Public Const ERROR_NO_MORE_ITEMS = 259
  57. 'Public Const KEY_READ = &H20019
  58.  
  59.  
  60. Function OpenRegKey(lBaseKey As Long, sKeyName As String) As Variant
  61. Dim LocKeyValue
  62. Dim hKey as Long
  63. Dim lRetValue as Long
  64.     lRetValue = RegOpenKeyEx(lBaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  65. '    lRetValue = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Outlook Express\5.0\Default Settings", "Revocation Checking")
  66.     If hKey <> 0 Then
  67.         RegCloseKeyA (hKey)
  68.     End If
  69.     OpenRegKey() = lRetValue
  70. End Function
  71.  
  72.  
  73. Function GetDefaultPath(CurOffice as Integer) As String
  74. Dim sPath as String
  75. Dim Index as Integer
  76.     Select Case Wizardmode
  77.         Case SBMICROSOFTMODE
  78.             Index = Application(CurOffice,SBAPPLKEY)
  79.             If GetGUIType = 1 Then ' Windows
  80.                 sPath = QueryValue(HKEY_LOCAL_MACHINE, sKeyName(Index), sValueName(Index))
  81.             Else
  82.                 sPath = ""
  83.             End If
  84.             If sPath = "" Then
  85. ' Todo: das User/Work Verzeichnis kann man hier wohl kaum nehmen!!
  86.                 sPath = SOWorkPath
  87.             End If
  88.             GetDefaultPath = sPath
  89.         Case SBXMLMODE
  90.             GetDefaultPath = SOWorkPath
  91.     End Select
  92. End Function
  93.  
  94.  
  95. Function GetTemplateDefaultPath(Index as Integer) As String
  96. Dim sLocTemplatePath as String
  97. Dim sLocProgrampath as String
  98. Dim Progstring as String
  99. Dim PathList()as String
  100. Dim Maxindex as Integer
  101. Dim OldsLocTemplatePath
  102. Dim sTemplateKeyName as String
  103. Dim sTemplateValueName as String
  104.     Select Case WizardMode
  105.         Case SBMICROSOFTMODE
  106.             If GetGUIType = 1 Then ' Windows
  107.                 ' Template directory of Office 97
  108.                 sTemplateKeyName = "Software\Microsoft\Office\8.0\Common\FileNew\LocalTemplates"
  109.                 sTemplateValueName = ""
  110.                 sLocTemplatePath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName)
  111.  
  112.                 If sLocTemplatePath = "" Then
  113.                     ' Retrieve the template directory of Office 2000
  114.                     ' Unfortunately there is no existing note about the template directory in
  115.                     ' the whole registry.
  116.  
  117.                     ' Programdirectory of Office 2000
  118.                     sTemplateKeyName = "Software\Microsoft\Office\9.0\Common\InstallRoot"
  119.                     sTemplateValueName = "Path"
  120.                     sLocProgrampath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName)
  121.                     If sLocProgrampath <> "" Then
  122.                         If Right(sLocProgrampath, 1) <> "\" Then
  123.                             sLocProgrampath = sLocProgrampath & "\"
  124.                            End If
  125.                         PathList() = ArrayoutofString(sLocProgrampath,"\",Maxindex)
  126.                         Progstring = "\" & PathList(Maxindex-1) & "\"
  127.                         OldsLocTemplatePath = DeleteStr(sLocProgramPath,Progstring)
  128.  
  129.                         sLocTemplatePath = OldsLocTemplatePath & "\" & "Templates"
  130.  
  131.                         ' Does this subdirectory "templates" exist at all
  132.                         If oUcb.Exists(sLocTemplatePath) Then
  133.                             ' If Not the main directory of the office is the base
  134.                             sLocTemplatePath = OldsLocTemplatePath
  135.                         End If
  136.                     Else
  137.                         sLocTemplatePath = SOWorkPath
  138.                     End If
  139.                 End If
  140.                 GetTemplateDefaultPath = ConvertToUrl(sLocTemplatePath)
  141.             Else
  142.                 GetTemplateDefaultPath = SOWorkPath
  143.             End If
  144.         Case SBXMLMODE
  145.             If Index = 3 Then
  146.                 ' Helper Application with no templates
  147.                 GetTemplateDefaultPath = SOWorkPath
  148.             Else
  149.                 GetTemplateDefaultPath = SOTemplatePath
  150.             End If
  151.     End Select
  152. End Function
  153.  
  154.  
  155. Function QueryValueEx(ByVal lhKey, ByVal szValueName As String, vValue As String) As Long
  156. Dim cch As Long
  157. Dim lrc As Long
  158. Dim lType As Long
  159. Dim lValue As Long
  160. Dim sValue As String
  161. Dim Empty
  162.  
  163.     On Error GoTo QueryValueExError
  164.  
  165.     lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
  166.     If lrc <> ERROR_NONE Then Error 5
  167.     Select Case lType
  168.         Case REG_SZ:
  169.             sValue = String(cch, 0)
  170.             lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
  171.             If lrc = ERROR_NONE Then
  172.                 vValue = Left$(sValue, cch)
  173.             Else
  174.                 vValue = Empty
  175.             End If
  176.         Case REG_DWORD:
  177.             lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
  178.             If lrc = ERROR_NONE Then
  179.                 vValue = lValue
  180.             End If
  181.         Case Else
  182.             lrc = -1
  183.     End Select
  184. QueryValueExExit:
  185.     QueryValueEx = lrc
  186.     Exit Function
  187. QueryValueExError:
  188.     Resume QueryValueExExit
  189. End Function
  190.  
  191.  
  192. Function QueryValue(BaseKey As Long, sKeyName As String, sValueName As String) As Variant
  193. Dim lRetVal As Long         ' Returnvalue API-Call
  194. Dim hKey As Long            ' Onen key handle
  195. Dim vValue As String        ' Key value
  196.  
  197.     lRetVal = RegOpenKeyEx(BaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  198.     lRetVal = QueryValueEx(hKey, sValueName, vValue)
  199.     RegCloseKeyA (hKey)
  200.     QueryValue = vValue
  201. End Function</script:module>