home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Vyzkuste / openoffice / f_0078 / Misc.xba < prev    next >
Extensible Markup Language  |  2001-12-18  |  23KB  |  719 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="Misc" script:language="StarBasic">REM  *****  BASIC  *****
  4.  
  5. Const SBSHARE = 0
  6. Const SBUSER = 1
  7. Dim Taskindex as Integer
  8. Dim oResSrv as Object
  9.  
  10. Sub Main()
  11. Dim PropList(3,1)' as String
  12.     PropList(0,0) = "URL"
  13.     PropList(0,1) = "sdbc:odbc:Erica_Test_Unicode"
  14.     PropList(1,0) = "User"
  15.     PropList(1,1) = "extra"
  16.     PropList(2,0) = "Password"
  17.     PropList(2,1) = "extra"
  18.     PropList(3,0) = "IsPasswordRequired"
  19.     PropList(3,1) = True
  20. '    RegisterNewDataSource("Doc_Erica_Test_Unicode", PropList())
  21. End Sub
  22.  
  23.  
  24. Function RegisterNewDataSource(DSName as  String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
  25. Dim oDataSource as Object
  26. Dim oDBContext as Object
  27. Dim oPropInfo as Object
  28. Dim i as Integer
  29.     oDBContext = createUnoService("com.sun.star.sdb.DatabaseContext")
  30.     oDataSource = createUnoService("com.sun.star.sdb.DataSource")
  31.     For i = 0 To Ubound(PropertyList(), 1)
  32.         sPropName = PropertyList(i,0)
  33.         sPropValue = PropertyList(i,1)
  34.         oDataSource.SetPropertyValue(sPropName,sPropValue) 'GetByName(sPropName) = sPropValue 'oPropInfo.GetPropertyByName(sPropName)) = sPropValue '  PropertyList(i,0))) = PropertyList(i,1)
  35.     Next i
  36.     If Not IsMissing(DriverProperties()) Then
  37.         oDataSource.Info() = DriverProperties()
  38.     End If
  39.     oDBContext.RegisterObject(DSName, oDataSource)
  40.     RegisterNewDataSource () = oDataSource
  41. End Function
  42.  
  43.  
  44. ' Connects to a registered Database
  45. Function ConnecttoDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
  46. Dim oDBContext as Object
  47. Dim oDBSource as Object
  48. '    On Local Error Goto NOCONNECTION
  49.     oDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
  50.     If oDBContext.HasbyName(DSName) Then
  51.         oDBSource = oDBContext.GetByName(DSName)
  52.         ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
  53.     Else
  54.         If Not IsMissing(Namelist()) Then
  55.             If Not IsMissing(DriverProperties()) Then
  56.                 RegisterNewDataSource(DSName, PropertyList(), DriverProperties())
  57.             Else
  58.                 RegisterNewDataSource(DSName, PropertyList())
  59.             End If
  60.             oDBSource = oDBContext.GetByName(DSName)
  61.             ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
  62.         Else
  63.             Msgbox("DataSource " & DSName & " is not registered" , 16, GetProductname())
  64.             ConnectToDatabase() = NULL
  65.         End If
  66.     End If
  67. NOCONNECTION:
  68.     If Err <> 0 Then
  69.         Msgbox(Error$, 16, GetProductName())
  70.         Resume LEAVESUB
  71.         LEAVESUB:
  72.     End If
  73. End Function
  74.  
  75.  
  76. Function GetStarOfficeLocale() as New com.sun.star.lang.Locale
  77. Dim aLocLocale As New com.sun.star.lang.Locale
  78. Dim sLocale as String
  79. Dim sLocaleList(1)
  80. Dim oMasterKey
  81.     oMasterKey = GetRegistryKeyContent("org.openoffice.Setup/L10N/")
  82.     sLocale = oMasterKey.getByName("ooLocale")
  83.     sLocaleList() = ArrayoutofString(sLocale, "-")
  84.     aLocLocale.Language = sLocaleList(0)
  85.     If Ubound(sLocaleList()) > 0 Then
  86.         aLocLocale.Country = sLocaleList(1)
  87.     End If
  88.     GetStarOfficeLocale() = aLocLocale
  89. End Function
  90.  
  91.  
  92. Function GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean)
  93. Dim oConfigProvider as Object
  94. Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
  95.     oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
  96.     aNodePath(0).Name = "nodepath"
  97.     aNodePath(0).Value = sKeyName
  98.     If IsMissing(bForUpdate) Then
  99.         GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath())
  100.     Else
  101.         If bForUpdate Then
  102.             GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath())
  103.         Else
  104.             GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath())
  105.         End If
  106.     End If
  107. End Function
  108.  
  109.  
  110. Function GetProductname() as String
  111. Dim oProdNameAccess as Object
  112. Dim sVersion as String
  113. Dim sProdName as String
  114.     oProdNameAccess = GetRegistryKeyContent("org.openoffice.Setup/Product")
  115.     sProdName = oProdNameAccess.getByName("ooName")
  116.     sVersion = oProdNameAccess.getByName("ooSetupVersion")
  117.     GetProductName = sProdName & sVersion
  118. End Function
  119.  
  120.  
  121. ' Opens a Document, checks beforehand, wether it has to be loaded
  122. ' or wether it is already on the desktop.
  123. ' If the parameter bDisposable is set to False then then returned document
  124. ' should not be disposed afterwards, because it is already opened.
  125. Function OpenDocument(DocPath as String, Args(), Optional bDisposable as Boolean)
  126. Dim oComponents as Object
  127. Dim oComponent as Object
  128.     ' Search if one of the active Components ist the one that you search for
  129.     oComponents = StarDesktop.Components.CreateEnumeration
  130.     While oComponents.HasmoreElements
  131.         oComponent = oComponents.NextElement
  132.         If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then
  133.             If UCase(oComponent.URL) = UCase(DocPath) then
  134.                 OpenDocument() = oComponent
  135.                 If Not IsMissing(bDisposable) Then
  136.                     bDisposable = False
  137.                 End If
  138.                 Exit Function
  139.             End If
  140.         End If
  141.     Wend
  142.     If Not IsMissing(bDisposable) Then
  143.         bDisposable = True
  144.     End If
  145.     OpenDocument() = StarDesktop.LoadComponentFromURL(DocPath,"_blank",0,Args())
  146. End Function
  147.  
  148.  
  149. Function TaskonDesktop(DocPath as String) as Boolean
  150. Dim oComponents as Object
  151. Dim oComponent as Object
  152.     ' Search if one of the active Components ist the one that you search for
  153.     oComponents = StarDesktop.Components.CreateEnumeration
  154.     While oComponents.HasmoreElements
  155.         oComponent = oComponents.NextElement
  156.             If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then
  157.             If UCase(oComponent.URL) = UCase(DocPath) then
  158.                 TaskonDesktop = True
  159.                 Exit Function
  160.             End If
  161.         End If
  162.     Wend
  163.     TaskonDesktop = False
  164. End Function
  165.  
  166.  
  167. ' Retrieves a FileName out of a StarOffice-Document
  168. Function RetrieveFileName(LocDoc as Object)
  169. Dim LocURL as String
  170. Dim LocURLArray() as String
  171. Dim MaxArrIndex as integer
  172.  
  173.     LocURL = LocDoc.Url
  174.     LocURLArray() = ArrayoutofString(LocURL,"/",MaxArrIndex)
  175.     RetrieveFileName = LocURLArray(MaxArrIndex)
  176. End Function
  177.  
  178.  
  179. ' Gets a special configured PathSetting
  180. Function GetPathSettings(sPathType as String,  Optional bshowall as Boolean, Optional ListIndex as integer) as String
  181. Dim oSettings, oPathSettings as Object
  182. Dim sPath as String
  183. Dim PathList() as String
  184. Dim MaxIndex as Integer
  185.  
  186.     oSettings = createUnoService("com.sun.star.frame.Settings")
  187.     oPathSettings = oSettings.getByName("PathSettings")
  188.       If Not IsMissing(bShowall) Then
  189.         If bShowAll Then
  190.             ShowPropertyValues(oPathSettings)
  191.             Exit Function
  192.         End If
  193.     End If
  194.      sPath = oPathSettings.GetPropertyValue(sPathType)
  195.     If Not IsMissing(ListIndex) Then
  196.         ' Share and User-Directory
  197.         If Instr(1,sPath,";") <> 0 Then
  198.             PathList = ArrayoutofString(sPath,";", MaxIndex)
  199.             If ListIndex <= MaxIndex Then
  200.                 sPath = PathList(ListIndex)
  201.             Else
  202.                 Msgbox("Cannot analyze the String " & sPath , 16, GetProductName())
  203.             End If
  204.         End If
  205.     End If
  206.     If Instr(1, sPath, ";") = 0 Then
  207.         GetPathSettings = ConvertToUrl(sPath)
  208.     Else
  209.         GetPathSettings = sPath
  210.     End If
  211. End Function
  212.  
  213.  
  214.  
  215. ' Gets the fully qualified path to a subdirectory of the
  216. ' Template Directory, e. g. with the parameter "wizard/bitmap"
  217. ' The parameter must be passed over in Url-scription
  218. ' The return-Value is in Urlscription
  219. Function GetOfficeSubPath(sOfficePath as String, ByVal sSubDir as String)
  220. Dim oUcb as Object
  221. Dim sOfficeString as String
  222. Dim sOfficeList() as String
  223. Dim sOfficeDir as String
  224. Dim sBigDir as String
  225. Dim i as Integer
  226. Dim MaxIndex as Integer
  227.     oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
  228.     sOfficeString = GetPathSettings(sOfficePath)
  229.     If Right(sSubDir,1) <> "/" Then
  230.         sSubDir = sSubDir & "/"
  231.     End If
  232.     sOfficeList() = ArrayoutofString(sOfficeString,";", MaxIndex)
  233.     For i = 0 To MaxIndex
  234.         sOfficeDir = ConvertToUrl(sOfficeList(i))
  235.         If Right(sOfficeDir,1) <> "/" Then
  236.             sOfficeDir = sOfficeDir & "/"
  237.         End If
  238.         sBigDir = sOfficeDir & sSubDir
  239.         If oUcb.Exists(sBigDir) Then
  240.             GetOfficeSubPath() = sBigDir
  241.             Exit Function
  242.         End If
  243.     Next i
  244.     GetOfficeSubPath = ""
  245. End Function
  246.  
  247.  
  248.  
  249. Function InitResources(Description, ShortDescription as String) as boolean
  250.     On Error Goto ErrorOcurred
  251.     oResSrv = createUnoService( "com.sun.star.resource.VclStringResourceLoader" )
  252.     If (IsNull(oResSrv)) then
  253.         InitResources = FALSE
  254.         MsgBox( Description & ": No resource loader found", 16, GetProductName())
  255.     Else
  256.         InitResources = TRUE
  257.         oResSrv.FileName = ShortDescription
  258.     End If
  259.     Exit Function
  260. ErrorOcurred:
  261.     Dim nSolarVer
  262.     InitResources = FALSE
  263.     nSolarVer = GetSolarVersion()
  264.     MsgBox("Resource file missing (" & ShortDescription  & trim(str(nSolarVer)) + "*.res)", 16, GetProductName())
  265.     Resume CLERROR
  266.     CLERROR:
  267. End Function
  268.  
  269.  
  270. Function GetResText( nID as integer ) As string
  271.     On Error Goto ErrorOcurred
  272.     If Not IsNull(oResSrv) Then
  273.         ' eigentlich sollte hier stehen
  274.         GetResText = oResSrv.getString( nID )
  275.     Else
  276.         GetResText = ""
  277.     End If
  278.     Exit Function
  279. ErrorOcurred:
  280.     GetResText = ""
  281.     MsgBox("Resource with ID =" + str( nID ) + " not found!", 16, GetProductName())
  282.     Resume CLERROR
  283.     CLERROR:
  284. End Function
  285.  
  286.  
  287. Function CutPathView(sDocUrl as String, Optional PathLen as Integer)
  288. Dim sViewPath as String
  289. Dim FileName as String
  290. Dim iFileLen as Integer
  291.     sViewPath = ConvertfromURL(sDocURL)
  292.     iViewPathLen = Len(sViewPath)
  293.     If iViewPathLen > 60 Then
  294.         FileName = FileNameoutofPath(sViewPath, "/")
  295.         iFileLen = Len(FileName)
  296.         If iFileLen < 44 Then
  297.             sViewPath = Left(sViewPath,57-iFileLen-10) & "..." & Right(sViewPath,iFileLen + 10)
  298.         Else
  299.             sViewPath = Left(sViewPath,27) & " ... " & Right(sViewPath,28)
  300.         End If
  301.     End If
  302.     CutPathView = sViewPath
  303. End Function
  304.  
  305.  
  306. ' Deletes the content of all cells that are softformatted according
  307. ' to the 'InputStyleName'
  308. Sub DeleteInputCells(oSheet as Object, InputStyleName as String)
  309. Dim oRanges as Object
  310. Dim oRange as Object
  311.     oRanges = oSheet.CellFormatRanges.createEnumeration
  312.     While oRanges.hasMoreElements
  313.         oRange = oRanges.NextElement
  314.         If Instr(1,oRange.CellStyle, InputStyleName) <> 0 Then
  315.             Call ReplaceRangeValues(oRange, "")
  316.         End If
  317.     Wend
  318. End Sub
  319.  
  320.  
  321. ' Inserts a certain String to all cells of a Range that ist passed over
  322. ' either as an object or as the RangeName
  323. Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String)
  324. Dim oCellRange as Object
  325.     If Vartype(Range) = 8 Then
  326.         ' Get the Range out of the Rangename
  327.         oCellRange = oSheet.GetCellRangeByName(Range)
  328.     Else
  329.         ' The range is passed over as an object
  330.         Set oCellRange = Range
  331.     End If
  332.     If IsMissing(StyleName) Then
  333.         ReplaceRangeValues(oCellRange, ReplaceValue)
  334.     Else
  335.         If Instr(1,oCellRange.CellStyle,StyleName) Then
  336.             ReplaceRangeValues(oCellRange, ReplaceValue)
  337.         End If
  338.     End If
  339. End Sub
  340.  
  341.  
  342. Sub ReplaceRangeValues(oRange as Object, ReplaceValue)
  343. Dim oRangeAddress as Object
  344. Dim ColCount as Integer
  345. Dim RowCount as Integer
  346. Dim i as Integer
  347.     oRangeAddress = oRange.RangeAddress
  348.     ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn
  349.     RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow
  350.     Dim FillArray(RowCount) as Variant
  351.     Dim sLine(ColCount) as Variant
  352.     For i = 0 To ColCount
  353.         sLine(i) = ReplaceValue
  354.     Next i
  355.     For i = 0 To RowCount
  356.         FillArray(i) = sLine()
  357.     Next i
  358.     oRange.DataArray = FillArray()
  359. End Sub
  360.  
  361.  
  362. ' Returns the Value of the first cell of a Range
  363. Function GetValueofCellbyName(oSheet as Object, sCellName as String)
  364. Dim oCell as Object
  365.     oCell = GetCellByName(oSheet, sCellName)
  366.     GetValueofCellbyName = oCell.Value
  367. End Function
  368.  
  369.  
  370. Function DuplicateRow(oSheet as Object, RangeName as String)
  371. Dim oRange as Object
  372. Dim oCell as Object
  373. Dim oCellAddress as New com.sun.star.table.CellAddress
  374. Dim oRangeAddress as New com.sun.star.table.CellRangeAddress
  375.     oRange = oSheet.GetCellRangeByName(RangeName)
  376.     oRangeAddress = oRange.RangeAddress
  377.     oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow)
  378.     oCellAddress = oCell.CellAddress
  379.     oSheet.Rows.InsertByIndex(oCellAddress.Row,1)
  380.     oRangeAddress = oRange.RangeAddress
  381.     oSheet.CopyRange(oCellAddress, oRangeAddress)
  382.     DuplicateRow = oRangeAddress.StartRow-1
  383. End Function
  384.  
  385.  
  386. ' Returns the String of the first cell of a Range
  387. Function GetStringofCellbyName(oSheet as Object, sCellName as String)
  388. Dim oCell as Object
  389.     oCell = GetCellByName(oSheet, sCellName)
  390.     GetStringofCellbyName = oCell.String
  391. End Function
  392.  
  393.  
  394. ' Returns a named Cell
  395. Function GetCellByName(oSheet as Object, sCellName as String) as Object
  396. Dim oCellRange as Object
  397. Dim oCellAddress as Object
  398.     oCellRange = oSheet.GetCellRangeByName(sCellName)
  399.     oCellAddress = oCellRange.RangeAddress
  400.     GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow)
  401. End Function
  402.  
  403.  
  404. ' Changes the numeric Value of a cell by transmitting the String of the numeric Value
  405. Sub ChangeCellValue(oCell as Object, ValueString as String)
  406. Dim CellValue
  407.     oCell.Formula = "=Value(" & """" & ValueString & """" & ")"
  408.     CellValue = oCell.Value
  409.     oCell.Formula = ""
  410.     oCell.Value = CellValue
  411. End Sub
  412.  
  413. Sub Main
  414. '    oDocument = StarDesktop.ActiveFrame.Controller.Model
  415.     oComponents = StarDesktop.Components.CreateEnumeration
  416.     Do
  417.         oComponent = oComponents.NextElement
  418.         ShowSupportedServicenames(oComponent)
  419.     Loop Until Not oComponents.HasMoreElements
  420.     For i = 0 To Ubound(StarDesktop.Components())
  421.         PrintdbgInfo StarDesktop.Components(i)
  422.     Next i
  423. End Sub
  424.  
  425.  
  426. Function GetDocumentType(oDocument)
  427.     On Local Error GoTo NODOCUMENTTYPE
  428.     If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
  429.         GetDocumentType() = "scalc"
  430.     ElseIf oDocument.SupportsService("com.sun.star.text.TextDocument") Then
  431.         GetDocumentType() = "swriter"
  432.     ElseIf oDocument.SupportsService("com.sun.star.drawing.DrawingDocument") Then
  433.         GetDocumentType() = "sdraw"
  434.     ElseIf oDocument.SupportsService("com.sun.star.formula.FormulaProperties") Then
  435.         GetDocumentType() = "smath"
  436.     End If
  437.     NODOCUMENTTYPE:
  438.     If Err <> 0 Then
  439.         GetDocumentType = ""
  440.         Resume GOON
  441.         GOON:
  442.     End If
  443. End Function
  444.  
  445.  
  446. Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer
  447. Dim ThisFormatKey as Long
  448. Dim oObjectFormat as Object
  449.     On Local Error Goto NOFORMAT
  450.     ThisFormatKey = oFormatObject.NumberFormat
  451.     oObjectFormat = oDocFormats.GetByKey(ThisFormatKey)
  452.     GetNumberFormatType = oObjectFormat.Type
  453.     NOFORMAT:
  454.     If Err <> 0 Then
  455.         Msgbox("Numberformat of Object is not available!", 16, GetProductName())
  456.         GetNumberFormatType = 0
  457.         GOTO NOERROR
  458.     End If
  459.     NOERROR:
  460.     On Local Error Goto 0
  461. End Function
  462.  
  463.  
  464. Sub ProtectSheets(Optional oSheets as Object)
  465. Dim i as Integer
  466. Dim oDocSheets as Object
  467.     If IsMissing(oSheets) Then
  468.         oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
  469.     Else
  470.         Set oDocSheets = oSheets
  471.     End If
  472.  
  473.     For i = 0 To oDocSheets.Count-1
  474.         oDocSheets(i).Protect("")
  475.     Next i
  476. End Sub
  477.  
  478.  
  479. Sub UnprotectSheets(Optional oSheets as Object)
  480. Dim i as Integer
  481. Dim oDocSheets as Object
  482.     If IsMissing(oSheets) Then
  483.         oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
  484.     Else
  485.         Set oDocSheets = oSheets
  486.     End If
  487.  
  488.     For i = 0 To oDocSheets.Count-1
  489.         oDocSheets(i).Unprotect("")
  490.     Next i
  491. End Sub
  492.  
  493.  
  494. Function GetRowIndex(oSheet as Object, RowName as String)
  495. Dim oRange as Object
  496.     oRange = oSheet.GetCellRangeByName(RowName)
  497.     GetRowIndex = oRange.RangeAddress.StartRow
  498. End Function
  499.  
  500.  
  501. Function GetColumnIndex(oSheet as Object, ColName as String)
  502. Dim oRange as Object
  503.     oRange = oSheet.GetCellRangeByName(ColName)
  504.     GetColumnIndex = oRange.RangeAddress.StartColumn
  505. End Function
  506.  
  507.  
  508. Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object
  509. Dim oSheet as Object
  510. Dim Count as Integer
  511. Dim BasicSheetName as String
  512.  
  513.     BasicSheetName = NewName
  514.     ' Copy the last table. Assumption: The last table is the template
  515.     On Local Error Goto RENAMESHEET
  516.     oSheets.CopybyName(OldName, NewName, DestPos)
  517.  
  518. RENAMESHEET:
  519.     oSheet = oSheets(DestPos)
  520.     If Err <> 0 Then
  521.         ' Test if renaming failed
  522.         Count = 2
  523.         Do While oSheet.Name <> NewName
  524.             NewName = BasicSheetName & "_" & Count
  525.             oSheet.Name = NewName
  526.             Count = Count + 1
  527.         Loop
  528.         Resume CL_ERROR
  529. CL_ERROR:
  530.     End If
  531.     CopySheetbyName = oSheet
  532. End Function
  533.  
  534.  
  535. ' Dis-or enables a Window and adjusts the mousepointer accordingly
  536. Sub ToggleWindow(bDoEnable as Boolean)
  537. Dim oWindow as Object
  538.     oWindow = StarDesktop.CurrentFrame.ComponentWindow
  539.     oWindow.Enable = bDoEnable
  540. End Sub
  541.  
  542.  
  543. Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String
  544. Dim nStartFlags as Long
  545. Dim nContFlags as Long
  546. Dim oCharService as Object
  547. Dim iSheetNameLength as Integer
  548. Dim iResultPos as Integer
  549. Dim WrongChar as String
  550. Dim oResult as Object
  551.     nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE
  552.     nContFlags = nStartFlags
  553.     oCharService = CreateUnoService("com.sun.star.i18n.CharacterClassification")
  554.     iSheetNameLength = Len(SheetName)
  555.     If IsMissing(oLocale) Then
  556.         oLocale = ThisComponent.CharLocale
  557.     End If
  558.     Do
  559.         oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, "", nContFlags, " ")
  560.         iResultPos = oResult.EndPos
  561.         If iResultPos < iSheetNameLength Then
  562.             WrongChar = Mid(SheetName, iResultPos+1,1)
  563.             SheetName = ReplaceString(SheetName,"_", WrongChar)
  564.         End If
  565.     Loop Until iResultPos = iSheetNameLength
  566.     CheckNewSheetname = SheetName
  567. End Function
  568.  
  569.  
  570. Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String)
  571. Dim Count as Integer
  572. Dim bSheetIsThere as Boolean
  573. Dim iSheetNameLength as Integer
  574.     iSheetNameLength = Len(SheetName)
  575.     Count = 2
  576.     Do
  577.         bSheetIsThere = oSheets.HasByName(SheetName)
  578.         If bSheetIsThere Then
  579.             SheetName = Right(SheetName,iSheetNameLength) & "_" & Count
  580.             Count = Count + 1
  581.         End If
  582.     Loop Until Not bSheetIsThere
  583.     AddNewSheetname = SheetName
  584. End Sub
  585.  
  586.  
  587. Function GetSheetIndex(oSheets, sName) as Integer
  588. Dim i as Integer
  589.     For i = 0 To oSheets.Count-1
  590.         If oSheets(i).Name = sName Then
  591.             GetSheetIndex = i
  592.             exit Function
  593.         End If
  594.     Next i
  595.     GetSheetIndex = -1
  596. End Function
  597.  
  598.  
  599. Function GetLastUsedRow(oSheet as Object) as Integer
  600. Dim oCell As Object
  601. Dim oCursor As Object
  602. Dim aAddress As Variant
  603.     oCell = oSheet.GetCellbyPosition(0, 0)
  604.     oCursor = oSheet.createCursorByRange(oCell)
  605.     oCursor.GotoEndOfUsedArea(True)
  606.     aAddress = oCursor.RangeAddress
  607.     GetLastUsedRow = aAddress.EndRow
  608. End Function
  609.  
  610.  
  611. ' Note To set a one lined frame you have to set the inner width to 0
  612. ' In the API all Units that refer to pt-Heights are "1/100mm"
  613. ' The convert factor from 1pt to 1/100 mm is approximately 35
  614. Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer)
  615. Dim aBorder as New com.sun.star.table.BorderLine
  616.     aBorder = oStyleBorder
  617.     aBorder.InnerLineWidth = iInnerLineWidth
  618.     aBorder.OuterLineWidth = iOuterLineWidth
  619.     ModifyBorderLineWidth = aBorder
  620. End Function
  621.  
  622.  
  623. Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String)
  624. Dim PropValue(1) as new com.sun.star.beans.PropertyValue
  625.     PropValue(0).Name = "EventType"
  626.     PropValue(0).Value = "StarBasic"
  627.     PropValue(1).Name = "Script"
  628.     PropValue(1).Value = "macro:///" & SubPath
  629.     oDocument.Events.ReplaceByName(EventName, PropValue())
  630. End Sub
  631.  
  632.  
  633.  
  634. Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue)
  635. Dim MaxIndex as Integer
  636. Dim i as Integer
  637. Dim a as Integer
  638.     MaxIndex = Ubound(oContent())
  639.     bDoReplace = False
  640.     For i = 0 To MaxIndex
  641.         a = GetPropertyValueIndex(oContent(i).Name, TargetProperties())
  642.         If a <> -1 Then
  643.             If Vartype(TargetProperties(a).Value) <> 9 Then
  644.                 If TargetProperties(a).Value <> oContent(i).Value Then
  645.                     oContent(i).Value = TargetProperties(a).Value
  646.                     bDoReplace = True
  647.                 End If
  648.             Else
  649.                 If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then
  650.                     oContent(i).Value = TargetProperties(a).Value
  651.                     bDoReplace = True
  652.                 End If
  653.             End If
  654.         End If
  655.     Next i
  656.     ModifyPropertyValue() = bDoReplace
  657. End Function
  658.  
  659.  
  660. Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer
  661. Dim i as Integer
  662.     For i = 0 To Ubound(TargetProperties())
  663.         If Searchname = TargetProperties(i).Name Then
  664.             GetPropertyValueIndex = i
  665.             Exit Function
  666.         End If
  667.     Next i
  668.     GetPropertyValueIndex() = -1
  669. End Function
  670.  
  671.  
  672. Sub DispatchSlot(SlotID as Integer)
  673. Dim oArg() as new com.sun.star.beans.PropertyValue
  674. Dim oUrl as new com.sun.star.util.URL
  675. Dim oTrans as Object
  676. Dim oDisp as Object
  677.     oTrans = createUNOService("com.sun.star.util.URLTransformer")
  678.     oUrl.Complete = "slot:" & CStr(SlotID)
  679.     oTrans.parsestrict(oUrl)
  680.     oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, "_self", 0)
  681.     oDisp.dispatch(oUrl, oArg())
  682. End Sub
  683.  
  684.  
  685. 'returns the type of the office application
  686. 'FatOffice = 0, WebTop = 1
  687. 'This routine has to be changed if the Product Name is being changed!
  688. Function IsFatOffice() As Boolean
  689.   If sProductname = "" Then
  690.     sProductname = GetProductname()
  691.   End If
  692.   IsFatOffice = TRUE
  693.   'The following line has to include the current productname
  694.   If Instr(1,sProductname,"WebTop",1) <> 0 Then
  695.     IsFatOffice = FALSE
  696.   End If
  697. End Function
  698.  
  699.  
  700. Function GetLocale(sLanguage as String, sCountry as String)
  701. Dim oLocale as New com.sun.star.lang.Locale
  702.     oLocale.Language = sLanguage
  703.     oLocale.Country = sCountry
  704.     GetLocale = oLocale
  705. End Function
  706.  
  707.  
  708. Sub ToggleDesignMode(oDocument as Object)
  709. Dim aSwitchMode as new com.sun.star.util.URL
  710.     aSwitchMode.Complete = ".uno:SwitchControlDesignMode"
  711.     aTransformer = createUnoService("com.sun.star.util.URLTransformer")
  712.     aTransformer.parseStrict(aSwitchMode)
  713.     oFrame = oDocument.currentController.Frame
  714.     oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63)
  715.         Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue
  716.     oDispatch.dispatch(aSwitchMode, aEmptyArgs())
  717.     Erase aSwitchMode
  718. End Sub</script:module>
  719.