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