1<?xml version="1.0" encoding="UTF-8"?> 2<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> 3<!--*********************************************************** 4 * 5 * Licensed to the Apache Software Foundation (ASF) under one 6 * or more contributor license agreements. See the NOTICE file 7 * distributed with this work for additional information 8 * regarding copyright ownership. The ASF licenses this file 9 * to you under the Apache License, Version 2.0 (the 10 * "License"); you may not use this file except in compliance 11 * with the License. You may obtain a copy of the License at 12 * 13 * http://www.apache.org/licenses/LICENSE-2.0 14 * 15 * Unless required by applicable law or agreed to in writing, 16 * software distributed under the License is distributed on an 17 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 18 * KIND, either express or implied. See the License for the 19 * specific language governing permissions and limitations 20 * under the License. 21 * 22 ***********************************************************--> 23<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Misc" script:language="StarBasic">REM ***** BASIC ***** 24 25Const SBSHARE = 0 26Const SBUSER = 1 27Dim Taskindex as Integer 28Dim oResSrv as Object 29 30Sub Main() 31Dim PropList(3,1)' as String 32 PropList(0,0) = "URL" 33 PropList(0,1) = "sdbc:odbc:Erica_Test_Unicode" 34 PropList(1,0) = "User" 35 PropList(1,1) = "extra" 36 PropList(2,0) = "Password" 37 PropList(2,1) = "extra" 38 PropList(3,0) = "IsPasswordRequired" 39 PropList(3,1) = True 40End Sub 41 42 43Function RegisterNewDataSource(DSName as String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) 44Dim oDataSource as Object 45Dim oDBContext as Object 46Dim oPropInfo as Object 47Dim i as Integer 48 oDBContext = createUnoService("com.sun.star.sdb.DatabaseContext") 49 oDataSource = createUnoService("com.sun.star.sdb.DataSource") 50 For i = 0 To Ubound(PropertyList(), 1) 51 sPropName = PropertyList(i,0) 52 sPropValue = PropertyList(i,1) 53 oDataSource.SetPropertyValue(sPropName,sPropValue) 54 Next i 55 If Not IsMissing(DriverProperties()) Then 56 oDataSource.Info() = DriverProperties() 57 End If 58 oDBContext.RegisterObject(DSName, oDataSource) 59 RegisterNewDataSource () = oDataSource 60End Function 61 62 63' Connects to a registered Database 64Function ConnecttoDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) 65Dim oDBContext as Object 66Dim oDBSource as Object 67' On Local Error Goto NOCONNECTION 68 oDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") 69 If oDBContext.HasbyName(DSName) Then 70 oDBSource = oDBContext.GetByName(DSName) 71 ConnectToDatabase = oDBSource.GetConnection(UserID, Password) 72 Else 73 If Not IsMissing(Namelist()) Then 74 If Not IsMissing(DriverProperties()) Then 75 RegisterNewDataSource(DSName, PropertyList(), DriverProperties()) 76 Else 77 RegisterNewDataSource(DSName, PropertyList()) 78 End If 79 oDBSource = oDBContext.GetByName(DSName) 80 ConnectToDatabase = oDBSource.GetConnection(UserID, Password) 81 Else 82 Msgbox("DataSource " & DSName & " is not registered" , 16, GetProductname()) 83 ConnectToDatabase() = NULL 84 End If 85 End If 86NOCONNECTION: 87 If Err <> 0 Then 88 Msgbox(Error$, 16, GetProductName()) 89 Resume LEAVESUB 90 LEAVESUB: 91 End If 92End Function 93 94 95Function GetStarOfficeLocale() as New com.sun.star.lang.Locale 96Dim aLocLocale As New com.sun.star.lang.Locale 97Dim sLocale as String 98Dim sLocaleList(1) 99Dim oMasterKey 100 oMasterKey = GetRegistryKeyContent("org.openoffice.Setup/L10N/") 101 sLocale = oMasterKey.getByName("ooLocale") 102 sLocaleList() = ArrayoutofString(sLocale, "-") 103 aLocLocale.Language = sLocaleList(0) 104 If Ubound(sLocaleList()) > 0 Then 105 aLocLocale.Country = sLocaleList(1) 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, wether it has to be loaded 141' or wether it is already on the desktop. 142' If the parameter bDisposable is set to False then then 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 ist 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 ist 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 over in Url-scription 239' The return-Value is in Urlscription 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", "com") Then 280 ProductName = GetProductName() 281 sError = GetResText(1006) 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, ShortDescription as String) as boolean 294 On Error Goto ErrorOcurred 295 oResSrv = createUnoService( "com.sun.star.resource.VclStringResourceLoader" ) 296 If (IsNull(oResSrv)) then 297 InitResources = FALSE 298 MsgBox( Description & ": No resource loader found", 16, GetProductName()) 299 Else 300 InitResources = TRUE 301 oResSrv.FileName = ShortDescription 302 End If 303 Exit Function 304ErrorOcurred: 305 Dim nSolarVer 306 InitResources = FALSE 307 nSolarVer = GetSolarVersion() 308 MsgBox("Resource file missing (" & ShortDescription & trim(str(nSolarVer)) + "*.res)", 16, GetProductName()) 309 Resume CLERROR 310 CLERROR: 311End Function 312 313 314Function GetResText( nID as integer ) As string 315 On Error Goto ErrorOcurred 316 If Not IsNull(oResSrv) Then 317 GetResText = oResSrv.getString( nID ) 318 Else 319 GetResText = "" 320 End If 321 Exit Function 322ErrorOcurred: 323 GetResText = "" 324 MsgBox("Resource with ID =" + str( nID ) + " not found!", 16, GetProductName()) 325 Resume CLERROR 326 CLERROR: 327End Function 328 329 330Function CutPathView(sDocUrl as String, Optional PathLen as Integer) 331Dim sViewPath as String 332Dim FileName as String 333Dim iFileLen as Integer 334 sViewPath = ConvertfromURL(sDocURL) 335 iViewPathLen = Len(sViewPath) 336 If iViewPathLen > 60 Then 337 FileName = FileNameoutofPath(sViewPath, "/") 338 iFileLen = Len(FileName) 339 If iFileLen < 44 Then 340 sViewPath = Left(sViewPath,57-iFileLen-10) & "..." & Right(sViewPath,iFileLen + 10) 341 Else 342 sViewPath = Left(sViewPath,27) & " ... " & Right(sViewPath,28) 343 End If 344 End If 345 CutPathView = sViewPath 346End Function 347 348 349' Deletes the content of all cells that are softformatted according 350' to the 'InputStyleName' 351Sub DeleteInputCells(oSheet as Object, InputStyleName as String) 352Dim oRanges as Object 353Dim oRange as Object 354 oRanges = oSheet.CellFormatRanges.createEnumeration 355 While oRanges.hasMoreElements 356 oRange = oRanges.NextElement 357 If Instr(1,oRange.CellStyle, InputStyleName) <> 0 Then 358 Call ReplaceRangeValues(oRange, "") 359 End If 360 Wend 361End Sub 362 363 364' Inserts a certain String to all cells of a Range that ist passed over 365' either as an object or as the RangeName 366Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String) 367Dim oCellRange as Object 368 If Vartype(Range) = 8 Then 369 ' Get the Range out of the Rangename 370 oCellRange = oSheet.GetCellRangeByName(Range) 371 Else 372 ' The range is passed over as an object 373 Set oCellRange = Range 374 End If 375 If IsMissing(StyleName) Then 376 ReplaceRangeValues(oCellRange, ReplaceValue) 377 Else 378 If Instr(1,oCellRange.CellStyle,StyleName) Then 379 ReplaceRangeValues(oCellRange, ReplaceValue) 380 End If 381 End If 382End Sub 383 384 385Sub ReplaceRangeValues(oRange as Object, ReplaceValue) 386Dim oRangeAddress as Object 387Dim ColCount as Integer 388Dim RowCount as Integer 389Dim i as Integer 390 oRangeAddress = oRange.RangeAddress 391 ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn 392 RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow 393 Dim FillArray(RowCount) as Variant 394 Dim sLine(ColCount) as Variant 395 For i = 0 To ColCount 396 sLine(i) = ReplaceValue 397 Next i 398 For i = 0 To RowCount 399 FillArray(i) = sLine() 400 Next i 401 oRange.DataArray = FillArray() 402End Sub 403 404 405' Returns the Value of the first cell of a Range 406Function GetValueofCellbyName(oSheet as Object, sCellName as String) 407Dim oCell as Object 408 oCell = GetCellByName(oSheet, sCellName) 409 GetValueofCellbyName = oCell.Value 410End Function 411 412 413Function DuplicateRow(oSheet as Object, RangeName as String) 414Dim oRange as Object 415Dim oCell as Object 416Dim oCellAddress as New com.sun.star.table.CellAddress 417Dim oRangeAddress as New com.sun.star.table.CellRangeAddress 418 oRange = oSheet.GetCellRangeByName(RangeName) 419 oRangeAddress = oRange.RangeAddress 420 oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow) 421 oCellAddress = oCell.CellAddress 422 oSheet.Rows.InsertByIndex(oCellAddress.Row,1) 423 oRangeAddress = oRange.RangeAddress 424 oSheet.CopyRange(oCellAddress, oRangeAddress) 425 DuplicateRow = oRangeAddress.StartRow-1 426End Function 427 428 429' Returns the String of the first cell of a Range 430Function GetStringofCellbyName(oSheet as Object, sCellName as String) 431Dim oCell as Object 432 oCell = GetCellByName(oSheet, sCellName) 433 GetStringofCellbyName = oCell.String 434End Function 435 436 437' Returns a named Cell 438Function GetCellByName(oSheet as Object, sCellName as String) as Object 439Dim oCellRange as Object 440Dim oCellAddress as Object 441 oCellRange = oSheet.GetCellRangeByName(sCellName) 442 oCellAddress = oCellRange.RangeAddress 443 GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow) 444End Function 445 446 447' Changes the numeric Value of a cell by transmitting the String of the numeric Value 448Sub ChangeCellValue(oCell as Object, ValueString as String) 449Dim CellValue 450 oCell.Formula = "=Value(" & """" & ValueString & """" & ")" 451 CellValue = oCell.Value 452 oCell.Formula = "" 453 oCell.Value = CellValue 454End Sub 455 456 457Function GetDocumentType(oDocument) 458 On Local Error GoTo NODOCUMENTTYPE 459' ShowSupportedServiceNames(oDocument) 460 If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then 461 GetDocumentType() = "scalc" 462 ElseIf oDocument.SupportsService("com.sun.star.text.TextDocument") Then 463 GetDocumentType() = "swriter" 464 ElseIf oDocument.SupportsService("com.sun.star.drawing.DrawingDocument") Then 465 GetDocumentType() = "sdraw" 466 ElseIf oDocument.SupportsService("com.sun.star.presentation.PresentationDocument") Then 467 GetDocumentType() = "simpress" 468 ElseIf oDocument.SupportsService("com.sun.star.formula.FormulaProperties") Then 469 GetDocumentType() = "smath" 470 End If 471 NODOCUMENTTYPE: 472 If Err <> 0 Then 473 GetDocumentType = "" 474 Resume GOON 475 GOON: 476 End If 477End Function 478 479 480Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer 481Dim ThisFormatKey as Long 482Dim oObjectFormat as Object 483 On Local Error Goto NOFORMAT 484 ThisFormatKey = oFormatObject.NumberFormat 485 oObjectFormat = oDocFormats.GetByKey(ThisFormatKey) 486 GetNumberFormatType = oObjectFormat.Type 487 NOFORMAT: 488 If Err <> 0 Then 489 Msgbox("Numberformat of Object is not available!", 16, GetProductName()) 490 GetNumberFormatType = 0 491 GOTO NOERROR 492 End If 493 NOERROR: 494 On Local Error Goto 0 495End Function 496 497 498Sub ProtectSheets(Optional oSheets as Object) 499Dim i as Integer 500Dim oDocSheets as Object 501 If IsMissing(oSheets) Then 502 oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets 503 Else 504 Set oDocSheets = oSheets 505 End If 506 507 For i = 0 To oDocSheets.Count-1 508 oDocSheets(i).Protect("") 509 Next i 510End Sub 511 512 513Sub UnprotectSheets(Optional oSheets as Object) 514Dim i as Integer 515Dim oDocSheets as Object 516 If IsMissing(oSheets) Then 517 oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets 518 Else 519 Set oDocSheets = oSheets 520 End If 521 522 For i = 0 To oDocSheets.Count-1 523 oDocSheets(i).Unprotect("") 524 Next i 525End Sub 526 527 528Function GetRowIndex(oSheet as Object, RowName as String) 529Dim oRange as Object 530 oRange = oSheet.GetCellRangeByName(RowName) 531 GetRowIndex = oRange.RangeAddress.StartRow 532End Function 533 534 535Function GetColumnIndex(oSheet as Object, ColName as String) 536Dim oRange as Object 537 oRange = oSheet.GetCellRangeByName(ColName) 538 GetColumnIndex = oRange.RangeAddress.StartColumn 539End Function 540 541 542Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object 543Dim oSheet as Object 544Dim Count as Integer 545Dim BasicSheetName as String 546 547 BasicSheetName = NewName 548 ' Copy the last table. Assumption: The last table is the template 549 On Local Error Goto RENAMESHEET 550 oSheets.CopybyName(OldName, NewName, DestPos) 551 552RENAMESHEET: 553 oSheet = oSheets(DestPos) 554 If Err <> 0 Then 555 ' Test if renaming failed 556 Count = 2 557 Do While oSheet.Name <> NewName 558 NewName = BasicSheetName & "_" & Count 559 oSheet.Name = NewName 560 Count = Count + 1 561 Loop 562 Resume CL_ERROR 563CL_ERROR: 564 End If 565 CopySheetbyName = oSheet 566End Function 567 568 569' Dis-or enables a Window and adjusts the mousepointer accordingly 570Sub ToggleWindow(bDoEnable as Boolean) 571Dim oWindow as Object 572 oWindow = StarDesktop.CurrentFrame.ComponentWindow 573 oWindow.Enable = bDoEnable 574End Sub 575 576 577Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String 578Dim nStartFlags as Long 579Dim nContFlags as Long 580Dim oCharService as Object 581Dim iSheetNameLength as Integer 582Dim iResultPos as Integer 583Dim WrongChar as String 584Dim oResult as Object 585 nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE 586 nContFlags = nStartFlags 587 oCharService = CreateUnoService("com.sun.star.i18n.CharacterClassification") 588 iSheetNameLength = Len(SheetName) 589 If IsMissing(oLocale) Then 590 oLocale = ThisComponent.CharLocale 591 End If 592 Do 593 oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, "", nContFlags, " ") 594 iResultPos = oResult.EndPos 595 If iResultPos < iSheetNameLength Then 596 WrongChar = Mid(SheetName, iResultPos+1,1) 597 SheetName = ReplaceString(SheetName,"_", WrongChar) 598 End If 599 Loop Until iResultPos = iSheetNameLength 600 CheckNewSheetname = SheetName 601End Function 602 603 604Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String) 605Dim Count as Integer 606Dim bSheetIsThere as Boolean 607Dim iSheetNameLength as Integer 608 iSheetNameLength = Len(SheetName) 609 Count = 2 610 Do 611 bSheetIsThere = oSheets.HasByName(SheetName) 612 If bSheetIsThere Then 613 SheetName = Right(SheetName,iSheetNameLength) & "_" & Count 614 Count = Count + 1 615 End If 616 Loop Until Not bSheetIsThere 617 AddNewSheetname = SheetName 618End Sub 619 620 621Function GetSheetIndex(oSheets, sName) as Integer 622Dim i as Integer 623 For i = 0 To oSheets.Count-1 624 If oSheets(i).Name = sName Then 625 GetSheetIndex = i 626 exit Function 627 End If 628 Next i 629 GetSheetIndex = -1 630End Function 631 632 633Function GetLastUsedRow(oSheet as Object) as Integer 634Dim oCell As Object 635Dim oCursor As Object 636Dim aAddress As Variant 637 oCell = oSheet.GetCellbyPosition(0, 0) 638 oCursor = oSheet.createCursorByRange(oCell) 639 oCursor.GotoEndOfUsedArea(True) 640 aAddress = oCursor.RangeAddress 641 GetLastUsedRow = aAddress.EndRow 642End Function 643 644 645' Note To set a one lined frame you have to set the inner width to 0 646' In the API all Units that refer to pt-Heights are "1/100mm" 647' The convert factor from 1pt to 1/100 mm is approximately 35 648Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer) 649Dim aBorder as New com.sun.star.table.BorderLine 650 aBorder = oStyleBorder 651 aBorder.InnerLineWidth = iInnerLineWidth 652 aBorder.OuterLineWidth = iOuterLineWidth 653 ModifyBorderLineWidth = aBorder 654End Function 655 656 657Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String) 658Dim PropValue(1) as new com.sun.star.beans.PropertyValue 659 PropValue(0).Name = "EventType" 660 PropValue(0).Value = "StarBasic" 661 PropValue(1).Name = "Script" 662 PropValue(1).Value = "macro:///" & SubPath 663 oDocument.Events.ReplaceByName(EventName, PropValue()) 664End Sub 665 666 667 668Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue) 669Dim MaxIndex as Integer 670Dim i as Integer 671Dim a as Integer 672 MaxIndex = Ubound(oContent()) 673 bDoReplace = False 674 For i = 0 To MaxIndex 675 a = GetPropertyValueIndex(oContent(i).Name, TargetProperties()) 676 If a <> -1 Then 677 If Vartype(TargetProperties(a).Value) <> 9 Then 678 If TargetProperties(a).Value <> oContent(i).Value Then 679 oContent(i).Value = TargetProperties(a).Value 680 bDoReplace = True 681 End If 682 Else 683 If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then 684 oContent(i).Value = TargetProperties(a).Value 685 bDoReplace = True 686 End If 687 End If 688 End If 689 Next i 690 ModifyPropertyValue() = bDoReplace 691End Function 692 693 694Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer 695Dim i as Integer 696 For i = 0 To Ubound(TargetProperties()) 697 If Searchname = TargetProperties(i).Name Then 698 GetPropertyValueIndex = i 699 Exit Function 700 End If 701 Next i 702 GetPropertyValueIndex() = -1 703End Function 704 705 706Sub DispatchSlot(SlotID as Integer) 707Dim oArg() as new com.sun.star.beans.PropertyValue 708Dim oUrl as new com.sun.star.util.URL 709Dim oTrans as Object 710Dim oDisp as Object 711 oTrans = createUNOService("com.sun.star.util.URLTransformer") 712 oUrl.Complete = "slot:" & CStr(SlotID) 713 oTrans.parsestrict(oUrl) 714 oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, "_self", 0) 715 oDisp.dispatch(oUrl, oArg()) 716End Sub 717 718 719'returns the type of the office application 720'FatOffice = 0, WebTop = 1 721'This routine has to be changed if the Product Name is being changed! 722Function IsFatOffice() As Boolean 723 If sProductname = "" Then 724 sProductname = GetProductname() 725 End If 726 IsFatOffice = TRUE 727 'The following line has to include the current productname 728 If Instr(1,sProductname,"WebTop",1) <> 0 Then 729 IsFatOffice = FALSE 730 End If 731End Function 732 733 734Function GetLocale(sLanguage as String, sCountry as String) 735Dim oLocale as New com.sun.star.lang.Locale 736 oLocale.Language = sLanguage 737 oLocale.Country = sCountry 738 GetLocale = oLocale 739End Function 740 741 742Sub ToggleDesignMode(oDocument as Object) 743Dim aSwitchMode as new com.sun.star.util.URL 744 aSwitchMode.Complete = ".uno:SwitchControlDesignMode" 745 aTransformer = createUnoService("com.sun.star.util.URLTransformer") 746 aTransformer.parseStrict(aSwitchMode) 747 oFrame = oDocument.currentController.Frame 748 oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63) 749 Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue 750 oDispatch.dispatch(aSwitchMode, aEmptyArgs()) 751 Erase aSwitchMode 752End Sub 753 754 755Function isHighContrast(oPeer as Object) 756 Dim UIColor as Long 757 Dim myRed as Integer 758 Dim myGreen as Integer 759 Dim myBlue as Integer 760 Dim myLuminance as Double 761 762 UIColor = oPeer.getProperty( "DisplayBackgroundColor" ) 763 myRed = Red (UIColor) 764 myGreen = Green (UIColor) 765 myBlue = Blue (UIColor) 766 myLuminance = (( myBlue*28 + myGreen*151 + myRed*77 ) / 256 ) 767 isHighContrast = false 768 If myLuminance <= 25 Then isHighContrast = true 769End Function 770 771 772Function CreateNewDocument(sType as String, Optional sAddMsg as String) as Object 773Dim NoArgs() as new com.sun.star.beans.PropertyValue 774Dim oDocument as Object 775Dim sUrl as String 776Dim ErrMsg as String 777 On Local Error Goto NOMODULEINSTALLED 778 sUrl = "private:factory/" & sType 779 oDocument = StarDesktop.LoadComponentFromURL(sUrl,"_default",0, NoArgs()) 780NOMODULEINSTALLED: 781 If (Err <> 0) OR IsNull(oDocument) Then 782 If InitResources("", "com") Then 783 Select Case sType 784 Case "swriter" 785 ErrMsg = GetResText(1001) 786 Case "scalc" 787 ErrMsg = GetResText(1002) 788 Case "simpress" 789 ErrMsg = GetResText(1003) 790 Case "sdraw" 791 ErrMsg = GetResText(1004) 792 Case "smath" 793 ErrMsg = GetResText(1005) 794 Case Else 795 ErrMsg = "Invalid Document Type!" 796 End Select 797 ErrMsg = ReplaceString(ErrMsg, chr(13), "<BR>") 798 If Not IsMissing(sAddMsg) Then 799 ErrMsg = ErrMsg & chr(13) & sAddMsg 800 End If 801 Msgbox(ErrMsg, 48, GetProductName()) 802 End If 803 If Err <> 0 Then 804 Resume GOON 805 End If 806 End If 807GOON: 808 CreateNewDocument = oDocument 809End Function 810 811 812' This Sub has been used in order to ensure that after disposing a document 813' from the backing window it is returned to the backing window, so the 814' office won't be closed 815Sub DisposeDocument(oDocument as Object) 816Dim dispatcher as Object 817Dim parser as Object 818Dim disp as Object 819Dim url as new com.sun.star.util.URL 820Dim NoArgs() as New com.sun.star.beans.PropertyValue 821Dim oFrame as Object 822 If Not IsNull(oDocument) Then 823 oDocument.setModified(false) 824 parser = createUnoService("com.sun.star.util.URLTransformer") 825 url.Complete = ".uno:CloseDoc" 826 parser.parseStrict(url) 827 oFrame = oDocument.CurrentController.Frame 828 disp = oFrame.queryDispatch(url,"_self", com.sun.star.util.SearchFlags.NORM_WORD_ONLY) 829 disp.dispatch(url, NoArgs()) 830 End If 831End Sub 832 833'Function to calculate if the year is a leap year 834Function CalIsLeapYear(ByVal iYear as Integer) as Boolean 835 CalIsLeapYear = ((iYear Mod 4 = 0) And ((iYear Mod 100 <> 0) Or (iYear Mod 400 = 0))) 836End Function 837</script:module> 838