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