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