home *** CD-ROM | disk | FTP | other *** search
/ PC World 2004 January / PCWorld_2004-01_cd.bin / akce / openoffice / f_0064 / API.xba next >
Extensible Markup Language  |  2002-11-07  |  7KB  |  200 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 = Applications(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.                 sPath = SOWorkPath
  86.             End If
  87.             GetDefaultPath = sPath
  88.         Case SBXMLMODE
  89.             GetDefaultPath = SOWorkPath
  90.     End Select
  91. End Function
  92.  
  93.  
  94. Function GetTemplateDefaultPath(Index as Integer) As String
  95. Dim sLocTemplatePath as String
  96. Dim sLocProgrampath as String
  97. Dim Progstring as String
  98. Dim PathList()as String
  99. Dim Maxindex as Integer
  100. Dim OldsLocTemplatePath
  101. Dim sTemplateKeyName as String
  102. Dim sTemplateValueName as String
  103.     Select Case WizardMode
  104.         Case SBMICROSOFTMODE
  105.             If GetGUIType = 1 Then ' Windows
  106.                 ' Template directory of Office 97
  107.                 sTemplateKeyName = "Software\Microsoft\Office\8.0\Common\FileNew\LocalTemplates"
  108.                 sTemplateValueName = ""
  109.                 sLocTemplatePath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName)
  110.  
  111.                 If sLocTemplatePath = "" Then
  112.                     ' Retrieve the template directory of Office 2000
  113.                     ' Unfortunately there is no existing note about the template directory in
  114.                     ' the whole registry.
  115.  
  116.                     ' Programdirectory of Office 2000
  117.                     sTemplateKeyName = "Software\Microsoft\Office\9.0\Common\InstallRoot"
  118.                     sTemplateValueName = "Path"
  119.                     sLocProgrampath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName)
  120.                     If sLocProgrampath <> "" Then
  121.                         If Right(sLocProgrampath, 1) <> "\" Then
  122.                             sLocProgrampath = sLocProgrampath & "\"
  123.                            End If
  124.                         PathList() = ArrayoutofString(sLocProgrampath,"\",Maxindex)
  125.                         Progstring = "\" & PathList(Maxindex-1) & "\"
  126.                         OldsLocTemplatePath = DeleteStr(sLocProgramPath,Progstring)
  127.  
  128.                         sLocTemplatePath = OldsLocTemplatePath & "\" & "Templates"
  129.  
  130.                         ' Does this subdirectory "templates" exist at all
  131.                         If oUcb.Exists(sLocTemplatePath) Then
  132.                             ' If Not the main directory of the office is the base
  133.                             sLocTemplatePath = OldsLocTemplatePath
  134.                         End If
  135.                     Else
  136.                         sLocTemplatePath = SOWorkPath
  137.                     End If
  138.                 End If
  139.                 GetTemplateDefaultPath = ConvertToUrl(sLocTemplatePath)
  140.             Else
  141.                 GetTemplateDefaultPath = SOWorkPath
  142.             End If
  143.         Case SBXMLMODE
  144.             If Index = 3 Then
  145.                 ' Helper Application with no templates
  146.                 GetTemplateDefaultPath = SOWorkPath
  147.             Else
  148.                 GetTemplateDefaultPath = SOTemplatePath
  149.             End If
  150.     End Select
  151. End Function
  152.  
  153.  
  154. Function QueryValueEx(ByVal lhKey, ByVal szValueName As String, vValue As String) As Long
  155. Dim cch As Long
  156. Dim lrc As Long
  157. Dim lType As Long
  158. Dim lValue As Long
  159. Dim sValue As String
  160. Dim Empty
  161.  
  162.     On Error GoTo QueryValueExError
  163.  
  164.     lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
  165.     If lrc <> ERROR_NONE Then Error 5
  166.     Select Case lType
  167.         Case REG_SZ:
  168.             sValue = String(cch, 0)
  169.             lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
  170.             If lrc = ERROR_NONE Then
  171.                 vValue = Left$(sValue, cch)
  172.             Else
  173.                 vValue = Empty
  174.             End If
  175.         Case REG_DWORD:
  176.             lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
  177.             If lrc = ERROR_NONE Then
  178.                 vValue = lValue
  179.             End If
  180.         Case Else
  181.             lrc = -1
  182.     End Select
  183. QueryValueExExit:
  184.     QueryValueEx = lrc
  185.     Exit Function
  186. QueryValueExError:
  187.     Resume QueryValueExExit
  188. End Function
  189.  
  190.  
  191. Function QueryValue(BaseKey As Long, sKeyName As String, sValueName As String) As Variant
  192. Dim lRetVal As Long         ' Returnvalue API-Call
  193. Dim hKey As Long            ' Onen key handle
  194. Dim vValue As String        ' Key value
  195.  
  196.     lRetVal = RegOpenKeyEx(BaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  197.     lRetVal = QueryValueEx(hKey, sValueName, vValue)
  198.     RegCloseKeyA (hKey)
  199.     QueryValue = vValue
  200. End Function</script:module>