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