diff options
| author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-27 16:51:28 +0000 |
|---|---|---|
| committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-27 16:51:28 +0000 |
| commit | 940b4d1848e8c70ab7642901a68594e8016caffc (patch) | |
| tree | eb72f344ee6c3d9b80a7ecc079ea79e9fba8676d /wizards/source/tools/Misc.xba | |
| parent | Initial commit. (diff) | |
| download | libreoffice-upstream.tar.xz libreoffice-upstream.zip | |
Adding upstream version 1:7.0.4.upstream/1%7.0.4upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/tools/Misc.xba | 841 |
1 files changed, 841 insertions, 0 deletions
diff --git a/wizards/source/tools/Misc.xba b/wizards/source/tools/Misc.xba new file mode 100644 index 000000000..9b9e1dba6 --- /dev/null +++ b/wizards/source/tools/Misc.xba @@ -0,0 +1,841 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<!-- + * This file is part of the LibreOffice project. + * + * This Source Code Form is subject to the terms of the Mozilla Public + * License, v. 2.0. If a copy of the MPL was not distributed with this + * file, You can obtain one at http://mozilla.org/MPL/2.0/. + * + * This file incorporates work covered by the following license notice: + * + * Licensed to the Apache Software Foundation (ASF) under one or more + * contributor license agreements. See the NOTICE file distributed + * with this work for additional information regarding copyright + * ownership. The ASF licenses this file to you under the Apache + * License, Version 2.0 (the "License"); you may not use this file + * except in compliance with the License. You may obtain a copy of + * the License at http://www.apache.org/licenses/LICENSE-2.0 . +--> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Misc" script:language="StarBasic">REM ***** BASIC ***** + +Const SBSHARE = 0 +Const SBUSER = 1 +Dim Taskindex as Integer +Dim oResSrv as Object + +Sub Main() +Dim PropList(3,1)' as String + PropList(0,0) = "URL" + PropList(0,1) = "sdbc:odbc:Erica_Test_Unicode" + PropList(1,0) = "User" + PropList(1,1) = "extra" + PropList(2,0) = "Password" + PropList(2,1) = "extra" + PropList(3,0) = "IsPasswordRequired" + PropList(3,1) = True +End Sub + + +Function RegisterNewDataSource(DSName as String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) +Dim oDataSource as Object +Dim oDBContext as Object +Dim oPropInfo as Object +Dim i as Integer + oDBContext = createUnoService("com.sun.star.sdb.DatabaseContext") + oDataSource = createUnoService("com.sun.star.sdb.DataSource") + For i = 0 To Ubound(PropertyList(), 1) + sPropName = PropertyList(i,0) + sPropValue = PropertyList(i,1) + oDataSource.SetPropertyValue(sPropName,sPropValue) + Next i + If Not IsMissing(DriverProperties()) Then + oDataSource.Info() = DriverProperties() + End If + oDBContext.RegisterObject(DSName, oDataSource) + RegisterNewDataSource () = oDataSource +End Function + + +' Connects to a registered Database +Function ConnecttoDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) +Dim oDBContext as Object +Dim oDBSource as Object +' On Local Error Goto NOCONNECTION + oDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + If oDBContext.HasbyName(DSName) Then + oDBSource = oDBContext.GetByName(DSName) + ConnectToDatabase = oDBSource.GetConnection(UserID, Password) + Else + If Not IsMissing(Namelist()) Then + If Not IsMissing(DriverProperties()) Then + RegisterNewDataSource(DSName, PropertyList(), DriverProperties()) + Else + RegisterNewDataSource(DSName, PropertyList()) + End If + oDBSource = oDBContext.GetByName(DSName) + ConnectToDatabase = oDBSource.GetConnection(UserID, Password) + Else + Msgbox("DataSource " & DSName & " is not registered" , 16, GetProductname()) + ConnectToDatabase() = NULL + End If + End If +NOCONNECTION: + If Err <> 0 Then + Msgbox(Error$, 16, GetProductName()) + Resume LEAVESUB + LEAVESUB: + End If +End Function + + +Function GetStarOfficeLocale() as New com.sun.star.lang.Locale +Dim aLocLocale As New com.sun.star.lang.Locale +Dim sLocale as String +Dim sLocaleList(1) +Dim oMasterKey + oMasterKey = GetRegistryKeyContent("org.openoffice.Setup/L10N/") + sLocale = oMasterKey.getByName("ooLocale") + sLocaleList() = ArrayoutofString(sLocale, "-") + aLocLocale.Language = sLocaleList(0) + If Ubound(sLocaleList()) > 0 Then + aLocLocale.Country = sLocaleList(1) + End If + If Ubound(sLocaleList()) > 1 Then + aLocLocale.Variant = sLocaleList(2) + End If + GetStarOfficeLocale() = aLocLocale +End Function + + +Function GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) +Dim oConfigProvider as Object +Dim aNodePath(0) as new com.sun.star.beans.PropertyValue + oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider") + aNodePath(0).Name = "nodepath" + aNodePath(0).Value = sKeyName + If IsMissing(bForUpdate) Then + GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath()) + Else + If bForUpdate Then + GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath()) + Else + GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath()) + End If + End If +End Function + + +Function GetProductname() as String +Dim oProdNameAccess as Object +Dim sVersion as String +Dim sProdName as String + oProdNameAccess = GetRegistryKeyContent("org.openoffice.Setup/Product") + sProdName = oProdNameAccess.getByName("ooName") + sVersion = oProdNameAccess.getByName("ooSetupVersion") + GetProductName = sProdName & sVersion +End Function + + +' Opens a Document, checks beforehand, whether it has to be loaded +' or whether it is already on the desktop. +' If the parameter bDisposable is set to False then the returned document +' should not be disposed afterwards, because it is already opened. +Function OpenDocument(DocPath as String, Args(), Optional bDisposable as Boolean) +Dim oComponents as Object +Dim oComponent as Object + ' Search if one of the active Components is the one that you search for + oComponents = StarDesktop.Components.CreateEnumeration + While oComponents.HasmoreElements + oComponent = oComponents.NextElement + If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then + If UCase(oComponent.URL) = UCase(DocPath) then + OpenDocument() = oComponent + If Not IsMissing(bDisposable) Then + bDisposable = False + End If + Exit Function + End If + End If + Wend + If Not IsMissing(bDisposable) Then + bDisposable = True + End If + OpenDocument() = StarDesktop.LoadComponentFromURL(DocPath,"_default",0,Args()) +End Function + + +Function TaskonDesktop(DocPath as String) as Boolean +Dim oComponents as Object +Dim oComponent as Object + ' Search if one of the active Components is the one that you search for + oComponents = StarDesktop.Components.CreateEnumeration + While oComponents.HasmoreElements + oComponent = oComponents.NextElement + If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then + If UCase(oComponent.URL) = UCase(DocPath) then + TaskonDesktop = True + Exit Function + End If + End If + Wend + TaskonDesktop = False +End Function + + +' Retrieves a FileName out of a StarOffice-Document +Function RetrieveFileName(LocDoc as Object) +Dim LocURL as String +Dim LocURLArray() as String +Dim MaxArrIndex as integer + + LocURL = LocDoc.Url + LocURLArray() = ArrayoutofString(LocURL,"/",MaxArrIndex) + RetrieveFileName = LocURLArray(MaxArrIndex) +End Function + + +' Gets a special configured PathSetting +Function GetPathSettings(sPathType as String, Optional bshowall as Boolean, Optional ListIndex as integer) as String +Dim oSettings, oPathSettings as Object +Dim sPath as String +Dim PathList() as String +Dim MaxIndex as Integer +Dim oPS as Object + + oPS = createUnoService("com.sun.star.util.PathSettings") + + If Not IsMissing(bShowall) Then + If bShowAll Then + ShowPropertyValues(oPS) + Exit Function + End If + End If + sPath = oPS.getPropertyValue(sPathType) + If Not IsMissing(ListIndex) Then + ' Share and User-Directory + If Instr(1,sPath,";") <> 0 Then + PathList = ArrayoutofString(sPath,";", MaxIndex) + If ListIndex <= MaxIndex Then + sPath = PathList(ListIndex) + Else + Msgbox("String Cannot be analyzed!" & sPath , 16, GetProductName()) + End If + End If + End If + If Instr(1, sPath, ";") = 0 Then + GetPathSettings = ConvertToUrl(sPath) + Else + GetPathSettings = sPath + End If + +End Function + + + +' Gets the fully qualified path to a subdirectory of the +' Template Directory, e. g. with the parameter "wizard/bitmap" +' The parameter must be passed in Url notation +' The return-Value is in Url notation +Function GetOfficeSubPath(sOfficePath as String, ByVal sSubDir as String) +Dim sOfficeString as String +Dim sOfficeList() as String +Dim sOfficeDir as String +Dim sBigDir as String +Dim i as Integer +Dim MaxIndex as Integer +Dim oUcb as Object + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + sOfficeString = GetPathSettings(sOfficePath) + If Right(sSubDir,1) <> "/" Then + sSubDir = sSubDir & "/" + End If + sOfficeList() = ArrayoutofString(sOfficeString,";", MaxIndex) + For i = 0 To MaxIndex + sOfficeDir = ConvertToUrl(sOfficeList(i)) + If Right(sOfficeDir,1) <> "/" Then + sOfficeDir = sOfficeDir & "/" + End If + sBigDir = sOfficeDir & sSubDir + If oUcb.Exists(sBigDir) Then + GetOfficeSubPath() = sBigDir + Exit Function + End If + Next i + ShowNoOfficePathError() + GetOfficeSubPath = "" +End Function + + +Sub ShowNoOfficePathError() +Dim ProductName as String +Dim sError as String +Dim bResObjectexists as Boolean +Dim oLocResSrv as Object + bResObjectexists = not IsNull(oResSrv) + If bResObjectexists Then + oLocResSrv = oResSrv + End If + If InitResources("Tools") Then + ProductName = GetProductName() + sError = GetResText("RID_COMMON_6") + sError = ReplaceString(sError, ProductName, "%PRODUCTNAME") + sError = ReplaceString(sError, chr(13), "<BR>") + MsgBox(sError, 16, ProductName) + End If + If bResObjectexists Then + oResSrv = oLocResSrv + End If + +End Sub + + +Function InitResources(Description) as boolean +Dim xResource as Object +Dim sOfficeDir as String +Dim aArgs(5) as Any + On Error Goto ErrorOcurred + sOfficeDir = "$BRAND_BASE_DIR/$BRAND_SHARE_SUBDIR/wizards/" + sOfficeDir = GetDefaultContext.getByName("/singletons/com.sun.star.util.theMacroExpander").ExpandMacros(sOfficeDir) + aArgs(0) = sOfficeDir + aArgs(1) = true + aArgs(2) = GetStarOfficeLocale() + aArgs(3) = "resources" + aArgs(4) = "" + aArgs(5) = NULL + oResSrv = getProcessServiceManager().createInstanceWithArguments( "com.sun.star.resource.StringResourceWithLocation", aArgs() ) + If (IsNull(oResSrv)) then + InitResources = FALSE + MsgBox("could not initialize StringResourceWithLocation") + Else + InitResources = TRUE + End If + Exit Function +ErrorOcurred: + Dim nSolarVer + InitResources = FALSE + nSolarVer = GetSolarVersion() + MsgBox("Resource file missing", 16, GetProductName()) + Resume CLERROR + CLERROR: +End Function + + +Function GetResText( sID as String ) As string +Dim sString as String + On Error Goto ErrorOcurred + If Not IsNull(oResSrv) Then + sString = oResSrv.resolveString(sID) + GetResText = ReplaceString(sString, GetProductname(), "%PRODUCTNAME") + Else + GetResText = "" + End If + Exit Function +ErrorOcurred: + GetResText = "" + MsgBox("Resource with ID =" + sID + " not found!", 16, GetProductName()) + Resume CLERROR + CLERROR: +End Function + + +Function CutPathView(sDocUrl as String, Optional PathLen as Integer) +Dim sViewPath as String +Dim FileName as String +Dim iFileLen as Integer + sViewPath = ConvertfromURL(sDocURL) + iViewPathLen = Len(sViewPath) + If iViewPathLen > 60 Then + FileName = FileNameoutofPath(sViewPath, "/") + iFileLen = Len(FileName) + If iFileLen < 44 Then + sViewPath = Left(sViewPath,57-iFileLen-10) & "..." & Right(sViewPath,iFileLen + 10) + Else + sViewPath = Left(sViewPath,27) & " ... " & Right(sViewPath,28) + End If + End If + CutPathView = sViewPath +End Function + + +' Deletes the content of all cells that are softformatted according +' to the 'InputStyleName' +Sub DeleteInputCells(oSheet as Object, InputStyleName as String) +Dim oRanges as Object +Dim oRange as Object + oRanges = oSheet.CellFormatRanges.createEnumeration + While oRanges.hasMoreElements + oRange = oRanges.NextElement + If Instr(1,oRange.CellStyle, InputStyleName) <> 0 Then + Call ReplaceRangeValues(oRange, "") + End If + Wend +End Sub + + +' Inserts a certain string to all cells of a range that is passed +' either as an object or as the RangeName +Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String) +Dim oCellRange as Object + If Vartype(Range) = 8 Then + ' Get the Range out of the Rangename + oCellRange = oSheet.GetCellRangeByName(Range) + Else + ' The range is passed as an object + Set oCellRange = Range + End If + If IsMissing(StyleName) Then + ReplaceRangeValues(oCellRange, ReplaceValue) + Else + If Instr(1,oCellRange.CellStyle,StyleName) Then + ReplaceRangeValues(oCellRange, ReplaceValue) + End If + End If +End Sub + + +Sub ReplaceRangeValues(oRange as Object, ReplaceValue) +Dim oRangeAddress as Object +Dim ColCount as Integer +Dim RowCount as Integer +Dim i as Integer + oRangeAddress = oRange.RangeAddress + ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn + RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow + Dim FillArray(RowCount) as Variant + Dim sLine(ColCount) as Variant + For i = 0 To ColCount + sLine(i) = ReplaceValue + Next i + For i = 0 To RowCount + FillArray(i) = sLine() + Next i + oRange.DataArray = FillArray() +End Sub + + +' Returns the Value of the first cell of a Range +Function GetValueofCellbyName(oSheet as Object, sCellName as String) +Dim oCell as Object + oCell = GetCellByName(oSheet, sCellName) + GetValueofCellbyName = oCell.Value +End Function + + +Function DuplicateRow(oSheet as Object, RangeName as String) +Dim oRange as Object +Dim oCell as Object +Dim oCellAddress as New com.sun.star.table.CellAddress +Dim oRangeAddress as New com.sun.star.table.CellRangeAddress + oRange = oSheet.GetCellRangeByName(RangeName) + oRangeAddress = oRange.RangeAddress + oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow) + oCellAddress = oCell.CellAddress + oSheet.Rows.InsertByIndex(oCellAddress.Row,1) + oRangeAddress = oRange.RangeAddress + oSheet.CopyRange(oCellAddress, oRangeAddress) + DuplicateRow = oRangeAddress.StartRow-1 +End Function + + +' Returns the String of the first cell of a Range +Function GetStringofCellbyName(oSheet as Object, sCellName as String) +Dim oCell as Object + oCell = GetCellByName(oSheet, sCellName) + GetStringofCellbyName = oCell.String +End Function + + +' Returns a named Cell +Function GetCellByName(oSheet as Object, sCellName as String) as Object +Dim oCellRange as Object +Dim oCellAddress as Object + oCellRange = oSheet.GetCellRangeByName(sCellName) + oCellAddress = oCellRange.RangeAddress + GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow) +End Function + + +' Changes the numeric Value of a cell by transmitting the String of the numeric Value +Sub ChangeCellValue(oCell as Object, ValueString as String) +Dim CellValue + oCell.Formula = "=Value(" & """" & ValueString & """" & ")" + CellValue = oCell.Value + oCell.Formula = "" + oCell.Value = CellValue +End Sub + + +Function GetDocumentType(oDocument) + On Local Error GoTo NODOCUMENTTYPE +' ShowSupportedServiceNames(oDocument) + If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then + GetDocumentType() = "scalc" + ElseIf oDocument.SupportsService("com.sun.star.text.TextDocument") Then + GetDocumentType() = "swriter" + ElseIf oDocument.SupportsService("com.sun.star.drawing.DrawingDocument") Then + GetDocumentType() = "sdraw" + ElseIf oDocument.SupportsService("com.sun.star.presentation.PresentationDocument") Then + GetDocumentType() = "simpress" + ElseIf oDocument.SupportsService("com.sun.star.formula.FormulaProperties") Then + GetDocumentType() = "smath" + End If + NODOCUMENTTYPE: + If Err <> 0 Then + GetDocumentType = "" + Resume GOON + GOON: + End If +End Function + + +Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer +Dim ThisFormatKey as Long +Dim oObjectFormat as Object + On Local Error Goto NOFORMAT + ThisFormatKey = oFormatObject.NumberFormat + oObjectFormat = oDocFormats.GetByKey(ThisFormatKey) + GetNumberFormatType = oObjectFormat.Type + NOFORMAT: + If Err <> 0 Then + Msgbox("Numberformat of Object is not available!", 16, GetProductName()) + GetNumberFormatType = 0 + GOTO NOERROR + End If + NOERROR: + On Local Error Goto 0 +End Function + + +Sub ProtectSheets(Optional oSheets as Object) +Dim i as Integer +Dim oDocSheets as Object + If IsMissing(oSheets) Then + oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets + Else + Set oDocSheets = oSheets + End If + + For i = 0 To oDocSheets.Count-1 + oDocSheets(i).Protect("") + Next i +End Sub + + +Sub UnprotectSheets(Optional oSheets as Object) +Dim i as Integer +Dim oDocSheets as Object + If IsMissing(oSheets) Then + oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets + Else + Set oDocSheets = oSheets + End If + + For i = 0 To oDocSheets.Count-1 + oDocSheets(i).Unprotect("") + Next i +End Sub + + +Function GetRowIndex(oSheet as Object, RowName as String) +Dim oRange as Object + oRange = oSheet.GetCellRangeByName(RowName) + GetRowIndex = oRange.RangeAddress.StartRow +End Function + + +Function GetColumnIndex(oSheet as Object, ColName as String) +Dim oRange as Object + oRange = oSheet.GetCellRangeByName(ColName) + GetColumnIndex = oRange.RangeAddress.StartColumn +End Function + + +Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object +Dim oSheet as Object +Dim Count as Integer +Dim BasicSheetName as String + + BasicSheetName = NewName + ' Copy the last table. Assumption: The last table is the template + On Local Error Goto RENAMESHEET + oSheets.CopybyName(OldName, NewName, DestPos) + +RENAMESHEET: + oSheet = oSheets(DestPos) + If Err <> 0 Then + ' Test if renaming failed + Count = 2 + Do While oSheet.Name <> NewName + NewName = BasicSheetName & "_" & Count + oSheet.Name = NewName + Count = Count + 1 + Loop + Resume CL_ERROR +CL_ERROR: + End If + CopySheetbyName = oSheet +End Function + + +' Dis-or enables a Window and adjusts the mousepointer accordingly +Sub ToggleWindow(bDoEnable as Boolean) +Dim oWindow as Object + oWindow = StarDesktop.CurrentFrame.ComponentWindow + oWindow.Enable = bDoEnable +End Sub + + +Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String +Dim nStartFlags as Long +Dim nContFlags as Long +Dim oCharService as Object +Dim iSheetNameLength as Integer +Dim iResultPos as Integer +Dim WrongChar as String +Dim oResult as Object + nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE + nContFlags = nStartFlags + oCharService = CreateUnoService("com.sun.star.i18n.CharacterClassification") + iSheetNameLength = Len(SheetName) + If IsMissing(oLocale) Then + oLocale = ThisComponent.CharLocale + End If + Do + oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, "", nContFlags, " ") + iResultPos = oResult.EndPos + If iResultPos < iSheetNameLength Then + WrongChar = Mid(SheetName, iResultPos+1,1) + SheetName = ReplaceString(SheetName,"_", WrongChar) + End If + Loop Until iResultPos = iSheetNameLength + CheckNewSheetname = SheetName +End Function + + +Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String) +Dim Count as Integer +Dim bSheetIsThere as Boolean +Dim iSheetNameLength as Integer + iSheetNameLength = Len(SheetName) + Count = 2 + Do + bSheetIsThere = oSheets.HasByName(SheetName) + If bSheetIsThere Then + SheetName = Right(SheetName,iSheetNameLength) & "_" & Count + Count = Count + 1 + End If + Loop Until Not bSheetIsThere + AddNewSheetname = SheetName +End Sub + + +Function GetSheetIndex(oSheets, sName) as Integer +Dim i as Integer + For i = 0 To oSheets.Count-1 + If oSheets(i).Name = sName Then + GetSheetIndex = i + exit Function + End If + Next i + GetSheetIndex = -1 +End Function + + +Function GetLastUsedRow(oSheet as Object) as Long +Dim oCell As Object +Dim oCursor As Object +Dim aAddress As Variant + oCell = oSheet.GetCellbyPosition(0, 0) + oCursor = oSheet.createCursorByRange(oCell) + oCursor.GotoEndOfUsedArea(True) + aAddress = oCursor.RangeAddress + GetLastUsedRow = aAddress.EndRow +End Function + + +' Note To set a one lined frame you have to set the inner width to 0 +' In the API all Units that refer to pt-Heights are "1/100mm" +' The convert factor from 1pt to 1/100 mm is approximately 35 +Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer) +Dim aBorder as New com.sun.star.table.BorderLine + aBorder = oStyleBorder + aBorder.InnerLineWidth = iInnerLineWidth + aBorder.OuterLineWidth = iOuterLineWidth + ModifyBorderLineWidth = aBorder +End Function + + +Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String) +Dim PropValue(1) as new com.sun.star.beans.PropertyValue + PropValue(0).Name = "EventType" + PropValue(0).Value = "StarBasic" + PropValue(1).Name = "Script" + PropValue(1).Value = "macro:///" & SubPath + oDocument.Events.ReplaceByName(EventName, PropValue()) +End Sub + + + +Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue) +Dim MaxIndex as Integer +Dim i as Integer +Dim a as Integer + MaxIndex = Ubound(oContent()) + bDoReplace = False + For i = 0 To MaxIndex + a = GetPropertyValueIndex(oContent(i).Name, TargetProperties()) + If a <> -1 Then + If Vartype(TargetProperties(a).Value) <> 9 Then + If TargetProperties(a).Value <> oContent(i).Value Then + oContent(i).Value = TargetProperties(a).Value + bDoReplace = True + End If + Else + If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then + oContent(i).Value = TargetProperties(a).Value + bDoReplace = True + End If + End If + End If + Next i + ModifyPropertyValue() = bDoReplace +End Function + + +Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer +Dim i as Integer + For i = 0 To Ubound(TargetProperties()) + If Searchname = TargetProperties(i).Name Then + GetPropertyValueIndex = i + Exit Function + End If + Next i + GetPropertyValueIndex() = -1 +End Function + + +Sub DispatchSlot(SlotID as Integer) +Dim oArg() as new com.sun.star.beans.PropertyValue +Dim oUrl as new com.sun.star.util.URL +Dim oTrans as Object +Dim oDisp as Object + oTrans = createUNOService("com.sun.star.util.URLTransformer") + oUrl.Complete = "slot:" & CStr(SlotID) + oTrans.parsestrict(oUrl) + oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, "_self", 0) + oDisp.dispatch(oUrl, oArg()) +End Sub + + +'returns the type of the office application +'FatOffice = 0, WebTop = 1 +'This routine has to be changed if the Product Name is being changed! +Function IsFatOffice() As Boolean + If sProductname = "" Then + sProductname = GetProductname() + End If + IsFatOffice = TRUE + 'The following line has to include the current productname + If Instr(1,sProductname,"WebTop",1) <> 0 Then + IsFatOffice = FALSE + End If +End Function + + +Sub ToggleDesignMode(oDocument as Object) +Dim aSwitchMode as new com.sun.star.util.URL + aSwitchMode.Complete = ".uno:SwitchControlDesignMode" + aTransformer = createUnoService("com.sun.star.util.URLTransformer") + aTransformer.parseStrict(aSwitchMode) + oFrame = oDocument.currentController.Frame + oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63) + Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue + oDispatch.dispatch(aSwitchMode, aEmptyArgs()) + Erase aSwitchMode +End Sub + + +Function isHighContrast(oPeer as Object) + Dim UIColor as Long + Dim myRed as Integer + Dim myGreen as Integer + Dim myBlue as Integer + Dim myLuminance as Double + + UIColor = oPeer.getProperty( "DisplayBackgroundColor" ) + myRed = Red (UIColor) + myGreen = Green (UIColor) + myBlue = Blue (UIColor) + myLuminance = (( myBlue*28 + myGreen*151 + myRed*77 ) / 256 ) + isHighContrast = false + If myLuminance <= 25 Then isHighContrast = true +End Function + + +Function CreateNewDocument(sType as String, Optional sAddMsg as String) as Object +Dim NoArgs() as new com.sun.star.beans.PropertyValue +Dim oDocument as Object +Dim sUrl as String +Dim ErrMsg as String + On Local Error Goto NOMODULEINSTALLED + sUrl = "private:factory/" & sType + oDocument = StarDesktop.LoadComponentFromURL(sUrl,"_default",0, NoArgs()) +NOMODULEINSTALLED: + If (Err <> 0) OR IsNull(oDocument) Then + If InitResources("") Then + Select Case sType + Case "swriter" + ErrMsg = GetResText("RID_COMMON_1") + Case "scalc" + ErrMsg = GetResText("RID_COMMON_2") + Case "simpress" + ErrMsg = GetResText("RID_COMMON_3") + Case "sdraw" + ErrMsg = GetResText("RID_COMMON_4") + Case "smath" + ErrMsg = GetResText("RID_COMMON_5") + Case Else + ErrMsg = "Invalid Document Type!" + End Select + ErrMsg = ReplaceString(ErrMsg, chr(13), "<BR>") + If Not IsMissing(sAddMsg) Then + ErrMsg = ErrMsg & chr(13) & sAddMsg + End If + Msgbox(ErrMsg, 48, GetProductName()) + End If + If Err <> 0 Then + Resume GOON + End If + End If +GOON: + CreateNewDocument = oDocument +End Function + + +' This Sub has been used in order to ensure that after disposing a document +' from the backing window it is returned to the backing window, so the +' office won't be closed +Sub DisposeDocument(oDocument as Object) +Dim dispatcher as Object +Dim parser as Object +Dim disp as Object +Dim url as new com.sun.star.util.URL +Dim NoArgs() as New com.sun.star.beans.PropertyValue +Dim oFrame as Object + If Not IsNull(oDocument) Then + oDocument.setModified(false) + parser = createUnoService("com.sun.star.util.URLTransformer") + url.Complete = ".uno:CloseDoc" + parser.parseStrict(url) + oFrame = oDocument.CurrentController.Frame + disp = oFrame.queryDispatch(url,"_self", com.sun.star.util.SearchFlags.NORM_WORD_ONLY) + disp.dispatch(url, NoArgs()) + End If +End Sub + +'Function to calculate if the year is a leap year +Function CalIsLeapYear(ByVal iYear as Integer) as Boolean + CalIsLeapYear = ((iYear Mod 4 = 0) And ((iYear Mod 100 <> 0) Or (iYear Mod 400 = 0))) +End Function +</script:module> |