wizards/source/tools/Misc.xba

   1 <?xml version="1.0" encoding="UTF-8"?>
   2 <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
   3 <!--
   4  * This file is part of the LibreOffice project.
   5  *
   6  * This Source Code Form is subject to the terms of the Mozilla Public
   7  * License, v. 2.0. If a copy of the MPL was not distributed with this
   8  * file, You can obtain one at http://mozilla.org/MPL/2.0/.
   9  *
  10  * This file incorporates work covered by the following license notice:
  11  *
  12  *   Licensed to the Apache Software Foundation (ASF) under one or more
  13  *   contributor license agreements. See the NOTICE file distributed
  14  *   with this work for additional information regarding copyright
  15  *   ownership. The ASF licenses this file to you under the Apache
  16  *   License, Version 2.0 (the "License"); you may not use this file
  17  *   except in compliance with the License. You may obtain a copy of
  18  *   the License at http://www.apache.org/licenses/LICENSE-2.0 .
  19 -->
  20 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Misc" script:language="StarBasic">REM  *****  BASIC  *****
  21
  22 Const SBSHARE = 0
  23 Const SBUSER = 1
  24 Dim Taskindex as Integer
  25 Dim oResSrv as Object
  26
  27 Sub Main()
  28 Dim PropList(3,1)&apos; as String
  29         PropList(0,0) = &quot;URL&quot;
  30         PropList(0,1) = &quot;sdbc:odbc:Erica_Test_Unicode&quot;
  31         PropList(1,0) = &quot;User&quot;
  32         PropList(1,1) = &quot;extra&quot;
  33         PropList(2,0) = &quot;Password&quot;
  34         PropList(2,1) = &quot;extra&quot;
  35         PropList(3,0) = &quot;IsPasswordRequired&quot;
  36         PropList(3,1) = True
  37 End Sub
  38
  39
  40 Function RegisterNewDataSource(DSName as  String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
  41 Dim oDataSource as Object
  42 Dim oDBContext as Object
  43 Dim oPropInfo as Object
  44 Dim i as Integer
  45     oDBContext = createUnoService(&quot;com.sun.star.sdb.DatabaseContext&quot;)
  46     oDataSource = createUnoService(&quot;com.sun.star.sdb.DataSource&quot;)
  47         For i = 0 To Ubound(PropertyList(), 1)
  48                 sPropName = PropertyList(i,0)
  49                 sPropValue = PropertyList(i,1)
  50                 oDataSource.SetPropertyValue(sPropName,sPropValue)
  51         Next i
  52         If Not IsMissing(DriverProperties()) Then
  53                 oDataSource.Info() = DriverProperties()
  54         End If
  55     oDBContext.RegisterObject(DSName, oDataSource)
  56         RegisterNewDataSource () = oDataSource
  57 End Function
  58
  59
  60 &apos; Connects to a registered Database
  61 Function ConnecttoDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
  62 Dim oDBContext as Object
  63 Dim oDBSource as Object
  64 &apos;  On Local Error Goto NOCONNECTION
  65         oDBContext = CreateUnoService(&quot;com.sun.star.sdb.DatabaseContext&quot;)
  66         If oDBContext.HasbyName(DSName) Then
  67                 oDBSource = oDBContext.GetByName(DSName)
  68                 ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
  69         Else
  70                 If Not IsMissing(Namelist()) Then
  71                         If Not IsMissing(DriverProperties()) Then
  72                                 RegisterNewDataSource(DSName, PropertyList(), DriverProperties())
  73                         Else
  74                                 RegisterNewDataSource(DSName, PropertyList())
  75                         End If
  76                         oDBSource = oDBContext.GetByName(DSName)
  77                         ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
  78                 Else
  79                         Msgbox(&quot;DataSource &quot; &amp; DSName &amp; &quot; is not registered&quot; , 16, GetProductname())
  80                         ConnectToDatabase() = NULL
  81                 End If
  82         End If
  83 NOCONNECTION:
  84         If Err &lt;&gt; 0 Then
  85                 Msgbox(Error$, 16, GetProductName())
  86                 Resume LEAVESUB
  87                 LEAVESUB:
  88         End If
  89 End Function
  90
  91
  92 Function GetStarOfficeLocale() as New com.sun.star.lang.Locale
  93 Dim aLocLocale As New com.sun.star.lang.Locale
  94 Dim sLocale as String
  95 Dim sLocaleList(1)
  96 Dim oMasterKey
  97         oMasterKey = GetRegistryKeyContent(&quot;org.openoffice.Setup/L10N/&quot;)
  98         sLocale = oMasterKey.getByName(&quot;ooLocale&quot;)
  99         sLocaleList() = ArrayoutofString(sLocale, &quot;-&quot;)
 100         aLocLocale.Language = sLocaleList(0)
 101         If Ubound(sLocaleList()) &gt; 0 Then
 102                 aLocLocale.Country = sLocaleList(1)
 103         End If
 104         GetStarOfficeLocale() = aLocLocale
 105 End Function
 106
 107
 108 Function GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean)
 109 Dim oConfigProvider as Object
 110 Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
 111         oConfigProvider = createUnoService(&quot;com.sun.star.configuration.ConfigurationProvider&quot;)
 112         aNodePath(0).Name = &quot;nodepath&quot;
 113         aNodePath(0).Value = sKeyName
 114         If IsMissing(bForUpdate) Then
 115                 GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
 116         Else
 117                 If bForUpdate Then
 118                         GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationUpdateAccess&quot;, aNodePath())
 119                 Else
 120                         GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
 121                 End If
 122         End If
 123 End Function
 124
 125
 126 Function GetProductname() as String
 127 Dim oProdNameAccess as Object
 128 Dim sVersion as String
 129 Dim sProdName as String
 130         oProdNameAccess = GetRegistryKeyContent(&quot;org.openoffice.Setup/Product&quot;)
 131         sProdName = oProdNameAccess.getByName(&quot;ooName&quot;)
 132         sVersion = oProdNameAccess.getByName(&quot;ooSetupVersion&quot;)
 133         GetProductName = sProdName &amp; sVersion
 134 End Function
 135
 136
 137 &apos; Opens a Document, checks beforehand, whether it has to be loaded
 138 &apos; or whether it is already on the desktop.
 139 &apos; If the parameter bDisposable is set to False then then returned document
 140 &apos; should not be disposed afterwards, because it is already opened.
 141 Function OpenDocument(DocPath as String, Args(), Optional bDisposable as Boolean)
 142 Dim oComponents as Object
 143 Dim oComponent as Object
 144         &apos; Search if one of the active Components is the one that you search for
 145         oComponents = StarDesktop.Components.CreateEnumeration
 146         While oComponents.HasmoreElements
 147                 oComponent = oComponents.NextElement
 148                 If hasUnoInterfaces(oComponent,&quot;com.sun.star.frame.XModel&quot;) then
 149                         If UCase(oComponent.URL) = UCase(DocPath) then
 150                                 OpenDocument() = oComponent
 151                                 If Not IsMissing(bDisposable) Then
 152                                         bDisposable = False
 153                                 End If
 154                                 Exit Function
 155                         End If
 156                 End If
 157         Wend
 158         If Not IsMissing(bDisposable) Then
 159                 bDisposable = True
 160         End If
 161         OpenDocument() = StarDesktop.LoadComponentFromURL(DocPath,&quot;_default&quot;,0,Args())
 162 End Function
 163
 164
 165 Function TaskonDesktop(DocPath as String) as Boolean
 166 Dim oComponents as Object
 167 Dim oComponent as Object
 168         &apos; Search if one of the active Components is the one that you search for
 169         oComponents = StarDesktop.Components.CreateEnumeration
 170         While oComponents.HasmoreElements
 171                 oComponent = oComponents.NextElement
 172                 If hasUnoInterfaces(oComponent,&quot;com.sun.star.frame.XModel&quot;) then
 173                         If UCase(oComponent.URL) = UCase(DocPath) then
 174                                 TaskonDesktop = True
 175                                 Exit Function
 176                         End If
 177                 End If
 178         Wend
 179         TaskonDesktop = False
 180 End Function
 181
 182
 183 &apos; Retrieves a FileName out of a StarOffice-Document
 184 Function RetrieveFileName(LocDoc as Object)
 185 Dim LocURL as String
 186 Dim LocURLArray() as String
 187 Dim MaxArrIndex as integer
 188
 189         LocURL = LocDoc.Url
 190         LocURLArray() = ArrayoutofString(LocURL,&quot;/&quot;,MaxArrIndex)
 191         RetrieveFileName = LocURLArray(MaxArrIndex)
 192 End Function
 193
 194
 195 &apos; Gets a special configured PathSetting
 196 Function GetPathSettings(sPathType as String,  Optional bshowall as Boolean, Optional ListIndex as integer) as String
 197 Dim oSettings, oPathSettings as Object
 198 Dim sPath as String
 199 Dim PathList() as String
 200 Dim MaxIndex as Integer
 201 Dim oPS as Object
 202
 203         oPS = createUnoService(&quot;com.sun.star.util.PathSettings&quot;)
 204
 205         If Not IsMissing(bShowall) Then
 206                 If bShowAll Then
 207                         ShowPropertyValues(oPS)
 208                         Exit Function
 209                 End If
 210         End If
 211         sPath = oPS.getPropertyValue(sPathType)
 212         If Not IsMissing(ListIndex) Then
 213                 &apos; Share and User-Directory
 214                 If Instr(1,sPath,&quot;;&quot;) &lt;&gt; 0 Then
 215                         PathList = ArrayoutofString(sPath,&quot;;&quot;, MaxIndex)
 216                         If ListIndex &lt;= MaxIndex Then
 217                                 sPath = PathList(ListIndex)
 218                         Else
 219                                 Msgbox(&quot;String Cannot be analyzed!&quot; &amp; sPath , 16, GetProductName())
 220                         End If
 221                 End If
 222         End If
 223         If Instr(1, sPath, &quot;;&quot;) = 0 Then
 224                 GetPathSettings = ConvertToUrl(sPath)
 225         Else
 226                 GetPathSettings = sPath
 227         End If
 228
 229 End Function
 230
 231
 232
 233 &apos; Gets the fully qualified path to a subdirectory of the
 234 &apos; Template Directory, e. g. with the parameter &quot;wizard/bitmap&quot;
 235 &apos; The parameter must be passed over in Url-scription
 236 &apos; The return-Value is in Urlscription
 237 Function GetOfficeSubPath(sOfficePath as String, ByVal sSubDir as String)
 238 Dim sOfficeString as String
 239 Dim sOfficeList() as String
 240 Dim sOfficeDir as String
 241 Dim sBigDir as String
 242 Dim i as Integer
 243 Dim MaxIndex as Integer
 244 Dim oUcb as Object
 245         oUcb = createUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
 246         sOfficeString = GetPathSettings(sOfficePath)
 247         If Right(sSubDir,1) &lt;&gt; &quot;/&quot; Then
 248                 sSubDir = sSubDir &amp; &quot;/&quot;
 249         End If
 250         sOfficeList() = ArrayoutofString(sOfficeString,&quot;;&quot;, MaxIndex)
 251         For i = 0 To MaxIndex
 252                 sOfficeDir = ConvertToUrl(sOfficeList(i))
 253                 If Right(sOfficeDir,1) &lt;&gt; &quot;/&quot; Then
 254                         sOfficeDir = sOfficeDir &amp; &quot;/&quot;
 255                 End If
 256                 sBigDir = sOfficeDir &amp; sSubDir
 257                 If oUcb.Exists(sBigDir) Then
 258                         GetOfficeSubPath() = sBigDir
 259                         Exit Function
 260                 End If
 261         Next i
 262         ShowNoOfficePathError()
 263         GetOfficeSubPath = &quot;&quot;
 264 End Function
 265
 266
 267 Sub ShowNoOfficePathError()
 268 Dim ProductName as String
 269 Dim sError as String
 270 Dim bResObjectexists as Boolean
 271 Dim oLocResSrv as Object
 272         bResObjectexists = not IsNull(oResSrv)
 273         If bResObjectexists Then
 274                 oLocResSrv = oResSrv
 275         End If
 276         If InitResources(&quot;Tools&quot;, &quot;com&quot;) Then
 277                 ProductName = GetProductName()
 278                 sError = GetResText(1006)
 279                 sError = ReplaceString(sError, ProductName, &quot;%PRODUCTNAME&quot;)
 280                 sError = ReplaceString(sError, chr(13), &quot;&lt;BR&gt;&quot;)
 281                 MsgBox(sError, 16, ProductName)
 282         End If
 283         If bResObjectexists Then
 284                 oResSrv = oLocResSrv
 285         End If
 286
 287 End Sub
 288
 289
 290 Function InitResources(Description, ShortDescription as String) as boolean
 291 Dim xResource as Object
 292 Dim aArgs(0) as String
 293         On Error Goto ErrorOcurred
 294         aArgs(0) = ShortDescription
 295         oConfigProvider = createUnoService(&quot;com.sun.star.configuration.ConfigurationProvider&quot;)
 296         xResource = getProcessServiceManager().createInstanceWithArguments( &quot;org.libreoffice.resource.ResourceIndexAccess&quot;, aArgs() )
 297         If (IsNull(xResource)) then
 298                 InitResources = FALSE
 299                 MsgBox(&quot;could not initialize ResourceIndexAccess&quot;)
 300         Else
 301                 InitResources = TRUE
 302                 oResSrv = xResource.getByName( &quot;String&quot; )
 303         End If
 304         Exit Function
 305 ErrorOcurred:
 306         Dim nSolarVer
 307         InitResources = FALSE
 308         nSolarVer = GetSolarVersion()
 309         MsgBox(&quot;Resource file missing (&quot; &amp; ShortDescription  &amp; trim(str(nSolarVer)) + &quot;*.res)&quot;, 16, GetProductName())
 310         Resume CLERROR
 311         CLERROR:
 312 End Function
 313
 314
 315 Function GetResText( nID as integer ) As string
 316         On Error Goto ErrorOcurred
 317         If Not IsNull(oResSrv) Then
 318                 GetResText = oResSrv.getByIndex( nID )
 319         Else
 320                 GetResText = &quot;&quot;
 321         End If
 322         Exit Function
 323 ErrorOcurred:
 324         GetResText = &quot;&quot;
 325         MsgBox(&quot;Resource with ID =&quot; + str( nID ) + &quot; not found!&quot;, 16, GetProductName())
 326         Resume CLERROR
 327         CLERROR:
 328 End Function
 329
 330
 331 Function CutPathView(sDocUrl as String, Optional PathLen as Integer)
 332 Dim sViewPath as String
 333 Dim FileName as String
 334 Dim iFileLen as Integer
 335         sViewPath = ConvertfromURL(sDocURL)
 336         iViewPathLen = Len(sViewPath)
 337         If iViewPathLen &gt; 60 Then
 338                 FileName = FileNameoutofPath(sViewPath, &quot;/&quot;)
 339                 iFileLen = Len(FileName)
 340                 If iFileLen &lt; 44 Then
 341                         sViewPath = Left(sViewPath,57-iFileLen-10) &amp; &quot;...&quot; &amp; Right(sViewPath,iFileLen + 10)
 342                 Else
 343                         sViewPath = Left(sViewPath,27) &amp; &quot; ... &quot; &amp; Right(sViewPath,28)
 344                 End If
 345         End If
 346         CutPathView = sViewPath
 347 End Function
 348
 349
 350 &apos; Deletes the content of all cells that are softformatted according
 351 &apos; to the &apos;InputStyleName&apos;
 352 Sub DeleteInputCells(oSheet as Object, InputStyleName as String)
 353 Dim oRanges as Object
 354 Dim oRange as Object
 355         oRanges = oSheet.CellFormatRanges.createEnumeration
 356         While oRanges.hasMoreElements
 357                 oRange = oRanges.NextElement
 358                 If Instr(1,oRange.CellStyle, InputStyleName) &lt;&gt; 0 Then
 359                         Call ReplaceRangeValues(oRange, &quot;&quot;)
 360                 End If
 361         Wend
 362 End Sub
 363
 364
 365 &apos; Inserts a certain String to all cells of a Range that ist passed over
 366 &apos; either as an object or as the RangeName
 367 Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String)
 368 Dim oCellRange as Object
 369         If Vartype(Range) = 8 Then
 370                 &apos; Get the Range out of the Rangename
 371                 oCellRange = oSheet.GetCellRangeByName(Range)
 372         Else
 373                 &apos; The range is passed over as an object
 374                 Set oCellRange = Range
 375         End If
 376         If IsMissing(StyleName) Then
 377                 ReplaceRangeValues(oCellRange, ReplaceValue)
 378         Else
 379                 If Instr(1,oCellRange.CellStyle,StyleName) Then
 380                         ReplaceRangeValues(oCellRange, ReplaceValue)
 381                 End If
 382         End If
 383 End Sub
 384
 385
 386 Sub ReplaceRangeValues(oRange as Object, ReplaceValue)
 387 Dim oRangeAddress as Object
 388 Dim ColCount as Integer
 389 Dim RowCount as Integer
 390 Dim i as Integer
 391         oRangeAddress = oRange.RangeAddress
 392         ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn
 393         RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow
 394         Dim FillArray(RowCount) as Variant
 395         Dim sLine(ColCount) as Variant
 396         For i = 0 To ColCount
 397                 sLine(i) = ReplaceValue
 398         Next i
 399         For i = 0 To RowCount
 400                 FillArray(i) = sLine()
 401         Next i
 402         oRange.DataArray = FillArray()
 403 End Sub
 404
 405
 406 &apos; Returns the Value of the first cell of a Range
 407 Function GetValueofCellbyName(oSheet as Object, sCellName as String)
 408 Dim oCell as Object
 409         oCell = GetCellByName(oSheet, sCellName)
 410         GetValueofCellbyName = oCell.Value
 411 End Function
 412
 413
 414 Function DuplicateRow(oSheet as Object, RangeName as String)
 415 Dim oRange as Object
 416 Dim oCell as Object
 417 Dim oCellAddress as New com.sun.star.table.CellAddress
 418 Dim oRangeAddress as New com.sun.star.table.CellRangeAddress
 419         oRange = oSheet.GetCellRangeByName(RangeName)
 420         oRangeAddress = oRange.RangeAddress
 421         oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow)
 422         oCellAddress = oCell.CellAddress
 423         oSheet.Rows.InsertByIndex(oCellAddress.Row,1)
 424         oRangeAddress = oRange.RangeAddress
 425         oSheet.CopyRange(oCellAddress, oRangeAddress)
 426         DuplicateRow = oRangeAddress.StartRow-1
 427 End Function
 428
 429
 430 &apos; Returns the String of the first cell of a Range
 431 Function GetStringofCellbyName(oSheet as Object, sCellName as String)
 432 Dim oCell as Object
 433         oCell = GetCellByName(oSheet, sCellName)
 434         GetStringofCellbyName = oCell.String
 435 End Function
 436
 437
 438 &apos; Returns a named Cell
 439 Function GetCellByName(oSheet as Object, sCellName as String) as Object
 440 Dim oCellRange as Object
 441 Dim oCellAddress as Object
 442         oCellRange = oSheet.GetCellRangeByName(sCellName)
 443         oCellAddress = oCellRange.RangeAddress
 444         GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow)
 445 End Function
 446
 447
 448 &apos; Changes the numeric Value of a cell by transmitting the String of the numeric Value
 449 Sub ChangeCellValue(oCell as Object, ValueString as String)
 450 Dim CellValue
 451         oCell.Formula = &quot;=Value(&quot; &amp; &quot;&quot;&quot;&quot; &amp; ValueString &amp; &quot;&quot;&quot;&quot; &amp; &quot;)&quot;
 452         CellValue = oCell.Value
 453         oCell.Formula = &quot;&quot;
 454         oCell.Value = CellValue
 455 End Sub
 456
 457
 458 Function GetDocumentType(oDocument)
 459         On Local Error GoTo NODOCUMENTTYPE
 460 &apos;  ShowSupportedServiceNames(oDocument)
 461         If oDocument.SupportsService(&quot;com.sun.star.sheet.SpreadsheetDocument&quot;) Then
 462                 GetDocumentType() = &quot;scalc&quot;
 463         ElseIf oDocument.SupportsService(&quot;com.sun.star.text.TextDocument&quot;) Then
 464                 GetDocumentType() = &quot;swriter&quot;
 465         ElseIf oDocument.SupportsService(&quot;com.sun.star.drawing.DrawingDocument&quot;) Then
 466                 GetDocumentType() = &quot;sdraw&quot;
 467         ElseIf oDocument.SupportsService(&quot;com.sun.star.presentation.PresentationDocument&quot;) Then
 468                 GetDocumentType() = &quot;simpress&quot;
 469         ElseIf oDocument.SupportsService(&quot;com.sun.star.formula.FormulaProperties&quot;) Then
 470                 GetDocumentType() = &quot;smath&quot;
 471         End If
 472         NODOCUMENTTYPE:
 473         If Err &lt;&gt; 0 Then
 474                 GetDocumentType = &quot;&quot;
 475                 Resume GOON
 476                 GOON:
 477         End If
 478 End Function
 479
 480
 481 Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer
 482 Dim ThisFormatKey as Long
 483 Dim oObjectFormat as Object
 484         On Local Error Goto NOFORMAT
 485         ThisFormatKey = oFormatObject.NumberFormat
 486         oObjectFormat = oDocFormats.GetByKey(ThisFormatKey)
 487         GetNumberFormatType = oObjectFormat.Type
 488         NOFORMAT:
 489         If Err &lt;&gt; 0 Then
 490                 Msgbox(&quot;Numberformat of Object is not available!&quot;, 16, GetProductName())
 491                 GetNumberFormatType = 0
 492                 GOTO NOERROR
 493         End If
 494         NOERROR:
 495         On Local Error Goto 0
 496 End Function
 497
 498
 499 Sub ProtectSheets(Optional oSheets as Object)
 500 Dim i as Integer
 501 Dim oDocSheets as Object
 502         If IsMissing(oSheets) Then
 503                 oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
 504         Else
 505                 Set oDocSheets = oSheets
 506         End If
 507
 508         For i = 0 To oDocSheets.Count-1
 509                 oDocSheets(i).Protect(&quot;&quot;)
 510         Next i
 511 End Sub
 512
 513
 514 Sub UnprotectSheets(Optional oSheets as Object)
 515 Dim i as Integer
 516 Dim oDocSheets as Object
 517         If IsMissing(oSheets) Then
 518                 oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
 519         Else
 520                 Set oDocSheets = oSheets
 521         End If
 522
 523         For i = 0 To oDocSheets.Count-1
 524                 oDocSheets(i).Unprotect(&quot;&quot;)
 525         Next i
 526 End Sub
 527
 528
 529 Function GetRowIndex(oSheet as Object, RowName as String)
 530 Dim oRange as Object
 531         oRange = oSheet.GetCellRangeByName(RowName)
 532         GetRowIndex = oRange.RangeAddress.StartRow
 533 End Function
 534
 535
 536 Function GetColumnIndex(oSheet as Object, ColName as String)
 537 Dim oRange as Object
 538         oRange = oSheet.GetCellRangeByName(ColName)
 539         GetColumnIndex = oRange.RangeAddress.StartColumn
 540 End Function
 541
 542
 543 Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object
 544 Dim oSheet as Object
 545 Dim Count as Integer
 546 Dim BasicSheetName as String
 547
 548         BasicSheetName = NewName
 549         &apos; Copy the last table. Assumption: The last table is the template
 550         On Local Error Goto RENAMESHEET
 551         oSheets.CopybyName(OldName, NewName, DestPos)
 552
 553 RENAMESHEET:
 554         oSheet = oSheets(DestPos)
 555         If Err &lt;&gt; 0 Then
 556                 &apos; Test if renaming failed
 557                 Count = 2
 558                 Do While oSheet.Name &lt;&gt; NewName
 559                         NewName = BasicSheetName &amp; &quot;_&quot; &amp; Count
 560                         oSheet.Name = NewName
 561                         Count = Count + 1
 562                 Loop
 563                 Resume CL_ERROR
 564 CL_ERROR:
 565         End If
 566         CopySheetbyName = oSheet
 567 End Function
 568
 569
 570 &apos; Dis-or enables a Window and adjusts the mousepointer accordingly
 571 Sub ToggleWindow(bDoEnable as Boolean)
 572 Dim oWindow as Object
 573         oWindow = StarDesktop.CurrentFrame.ComponentWindow
 574         oWindow.Enable = bDoEnable
 575 End Sub
 576
 577
 578 Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String
 579 Dim nStartFlags as Long
 580 Dim nContFlags as Long
 581 Dim oCharService as Object
 582 Dim iSheetNameLength as Integer
 583 Dim iResultPos as Integer
 584 Dim WrongChar as String
 585 Dim oResult as Object
 586         nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE
 587         nContFlags = nStartFlags
 588         oCharService = CreateUnoService(&quot;com.sun.star.i18n.CharacterClassification&quot;)
 589         iSheetNameLength = Len(SheetName)
 590         If IsMissing(oLocale) Then
 591                 oLocale = ThisComponent.CharLocale
 592         End If
 593         Do
 594                 oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, &quot;&quot;, nContFlags, &quot; &quot;)
 595                 iResultPos = oResult.EndPos
 596                 If iResultPos &lt; iSheetNameLength Then
 597                         WrongChar = Mid(SheetName, iResultPos+1,1)
 598                         SheetName = ReplaceString(SheetName,&quot;_&quot;, WrongChar)
 599                 End If
 600         Loop Until iResultPos = iSheetNameLength
 601         CheckNewSheetname = SheetName
 602 End Function
 603
 604
 605 Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String)
 606 Dim Count as Integer
 607 Dim bSheetIsThere as Boolean
 608 Dim iSheetNameLength as Integer
 609         iSheetNameLength = Len(SheetName)
 610         Count = 2
 611         Do
 612                 bSheetIsThere = oSheets.HasByName(SheetName)
 613                 If bSheetIsThere Then
 614                         SheetName = Right(SheetName,iSheetNameLength) &amp; &quot;_&quot; &amp; Count
 615                         Count = Count + 1
 616                 End If
 617         Loop Until Not bSheetIsThere
 618         AddNewSheetname = SheetName
 619 End Sub
 620
 621
 622 Function GetSheetIndex(oSheets, sName) as Integer
 623 Dim i as Integer
 624         For i = 0 To oSheets.Count-1
 625                 If oSheets(i).Name = sName Then
 626                         GetSheetIndex = i
 627                         exit Function
 628                 End If
 629         Next i
 630         GetSheetIndex = -1
 631 End Function
 632
 633
 634 Function GetLastUsedRow(oSheet as Object) as Integer
 635 Dim oCell As Object
 636 Dim oCursor As Object
 637 Dim aAddress As Variant
 638         oCell = oSheet.GetCellbyPosition(0, 0)
 639         oCursor = oSheet.createCursorByRange(oCell)
 640         oCursor.GotoEndOfUsedArea(True)
 641         aAddress = oCursor.RangeAddress
 642         GetLastUsedRow = aAddress.EndRow
 643 End Function
 644
 645
 646 &apos; Note To set a one lined frame you have to set the inner width to 0
 647 &apos; In the API all Units that refer to pt-Heights are &quot;1/100mm&quot;
 648 &apos; The convert factor from 1pt to 1/100 mm is approximately 35
 649 Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer)
 650 Dim aBorder as New com.sun.star.table.BorderLine
 651         aBorder = oStyleBorder
 652         aBorder.InnerLineWidth = iInnerLineWidth
 653         aBorder.OuterLineWidth = iOuterLineWidth
 654         ModifyBorderLineWidth = aBorder
 655 End Function
 656
 657
 658 Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String)
 659 Dim PropValue(1) as new com.sun.star.beans.PropertyValue
 660         PropValue(0).Name = &quot;EventType&quot;
 661         PropValue(0).Value = &quot;StarBasic&quot;
 662         PropValue(1).Name = &quot;Script&quot;
 663         PropValue(1).Value = &quot;macro:///&quot; &amp; SubPath
 664         oDocument.Events.ReplaceByName(EventName, PropValue())
 665 End Sub
 666
 667
 668
 669 Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue)
 670 Dim MaxIndex as Integer
 671 Dim i as Integer
 672 Dim a as Integer
 673         MaxIndex = Ubound(oContent())
 674         bDoReplace = False
 675         For i = 0 To MaxIndex
 676                 a = GetPropertyValueIndex(oContent(i).Name, TargetProperties())
 677                 If a &lt;&gt; -1 Then
 678                         If Vartype(TargetProperties(a).Value) &lt;&gt; 9 Then
 679                                 If TargetProperties(a).Value &lt;&gt; oContent(i).Value Then
 680                                         oContent(i).Value = TargetProperties(a).Value
 681                                         bDoReplace = True
 682                                 End If
 683                         Else
 684                                 If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then
 685                                         oContent(i).Value = TargetProperties(a).Value
 686                                         bDoReplace = True
 687                                 End If
 688                         End If
 689                 End If
 690         Next i
 691         ModifyPropertyValue() = bDoReplace
 692 End Function
 693
 694
 695 Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer
 696 Dim i as Integer
 697         For i = 0 To Ubound(TargetProperties())
 698                 If Searchname = TargetProperties(i).Name Then
 699                         GetPropertyValueIndex = i
 700                         Exit Function
 701                 End If
 702         Next i
 703         GetPropertyValueIndex() = -1
 704 End Function
 705
 706
 707 Sub DispatchSlot(SlotID as Integer)
 708 Dim oArg() as new com.sun.star.beans.PropertyValue
 709 Dim oUrl as new com.sun.star.util.URL
 710 Dim oTrans as Object
 711 Dim oDisp as Object
 712         oTrans = createUNOService(&quot;com.sun.star.util.URLTransformer&quot;)
 713         oUrl.Complete = &quot;slot:&quot; &amp; CStr(SlotID)
 714         oTrans.parsestrict(oUrl)
 715         oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, &quot;_self&quot;, 0)
 716         oDisp.dispatch(oUrl, oArg())
 717 End Sub
 718
 719
 720 &apos;returns the type of the office application
 721 &apos;FatOffice = 0, WebTop = 1
 722 &apos;This routine has to be changed if the Product Name is being changed!
 723 Function IsFatOffice() As Boolean
 724   If sProductname = &quot;&quot; Then
 725     sProductname = GetProductname()
 726   End If
 727   IsFatOffice = TRUE
 728   &apos;The following line has to include the current productname
 729   If Instr(1,sProductname,&quot;WebTop&quot;,1) &lt;&gt; 0 Then
 730     IsFatOffice = FALSE
 731   End If
 732 End Function
 733
 734
 735 Function GetLocale(sLanguage as String, sCountry as String)
 736 Dim oLocale as New com.sun.star.lang.Locale
 737         oLocale.Language = sLanguage
 738         oLocale.Country = sCountry
 739         GetLocale = oLocale
 740 End Function
 741
 742
 743 Sub ToggleDesignMode(oDocument as Object)
 744 Dim aSwitchMode as new com.sun.star.util.URL
 745         aSwitchMode.Complete = &quot;.uno:SwitchControlDesignMode&quot;
 746         aTransformer = createUnoService(&quot;com.sun.star.util.URLTransformer&quot;)
 747         aTransformer.parseStrict(aSwitchMode)
 748         oFrame = oDocument.currentController.Frame
 749         oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63)
 750         Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue
 751         oDispatch.dispatch(aSwitchMode, aEmptyArgs())
 752         Erase aSwitchMode
 753 End Sub
 754
 755
 756 Function isHighContrast(oPeer as Object)
 757         Dim UIColor as Long
 758         Dim myRed as Integer
 759         Dim myGreen as Integer
 760         Dim myBlue as Integer
 761         Dim myLuminance as Double
 762
 763         UIColor = oPeer.getProperty( &quot;DisplayBackgroundColor&quot; )
 764         myRed = Red (UIColor)
 765         myGreen = Green (UIColor)
 766         myBlue = Blue (UIColor)
 767         myLuminance = (( myBlue*28 + myGreen*151 + myRed*77 ) / 256     )
 768         isHighContrast = false
 769         If myLuminance &lt;= 25 Then isHighContrast = true
 770 End Function
 771
 772
 773 Function CreateNewDocument(sType as String, Optional sAddMsg as String) as Object
 774 Dim NoArgs() as new com.sun.star.beans.PropertyValue
 775 Dim oDocument as Object
 776 Dim sUrl as String
 777 Dim ErrMsg as String
 778         On Local Error Goto NOMODULEINSTALLED
 779         sUrl = &quot;private:factory/&quot; &amp; sType
 780         oDocument = StarDesktop.LoadComponentFromURL(sUrl,&quot;_default&quot;,0, NoArgs())
 781 NOMODULEINSTALLED:
 782         If (Err &lt;&gt; 0) OR IsNull(oDocument) Then
 783                 If InitResources(&quot;&quot;, &quot;com&quot;) Then
 784                         Select Case sType
 785                                 Case &quot;swriter&quot;
 786                                         ErrMsg = GetResText(1001)
 787                                 Case &quot;scalc&quot;
 788                                         ErrMsg = GetResText(1002)
 789                                 Case &quot;simpress&quot;
 790                                         ErrMsg = GetResText(1003)
 791                                 Case &quot;sdraw&quot;
 792                                         ErrMsg = GetResText(1004)
 793                                 Case &quot;smath&quot;
 794                                         ErrMsg = GetResText(1005)
 795                                 Case Else
 796                                         ErrMsg = &quot;Invalid Document Type!&quot;
 797                         End Select
 798                         ErrMsg = ReplaceString(ErrMsg, chr(13), &quot;&lt;BR&gt;&quot;)
 799                         If Not IsMissing(sAddMsg) Then
 800                                 ErrMsg = ErrMsg &amp; chr(13) &amp; sAddMsg
 801                         End If
 802                         Msgbox(ErrMsg, 48, GetProductName())
 803                 End If
 804                 If Err &lt;&gt; 0 Then
 805                         Resume GOON
 806                 End If
 807         End If
 808 GOON:
 809         CreateNewDocument = oDocument
 810 End Function
 811
 812
 813 &apos; This Sub has been used in order to ensure that after disposing a document
 814 &apos; from the backing window it is returned to the backing window, so the
 815 &apos; office won&apos;t be closed
 816 Sub DisposeDocument(oDocument as Object)
 817 Dim dispatcher as Object
 818 Dim parser as Object
 819 Dim disp as Object
 820 Dim url as new com.sun.star.util.URL
 821 Dim NoArgs() as New com.sun.star.beans.PropertyValue
 822 Dim oFrame as Object
 823         If Not IsNull(oDocument) Then
 824                 oDocument.setModified(false)
 825                 parser   = createUnoService(&quot;com.sun.star.util.URLTransformer&quot;)
 826                 url.Complete = &quot;.uno:CloseDoc&quot;
 827                 parser.parseStrict(url)
 828                 oFrame = oDocument.CurrentController.Frame
 829                 disp = oFrame.queryDispatch(url,&quot;_self&quot;, com.sun.star.util.SearchFlags.NORM_WORD_ONLY)
 830                 disp.dispatch(url, NoArgs())
 831         End If
 832 End Sub
 833
 834 &apos;Function to calculate if the year is a leap year
 835 Function CalIsLeapYear(ByVal iYear as Integer) as Boolean
 836         CalIsLeapYear = ((iYear Mod 4 = 0) And ((iYear Mod 100 &lt;&gt; 0) Or (iYear Mod 400 = 0)))
 837 End Function
 838 </script:module>