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