| <?xml version="1.0" encoding="UTF-8"?> |
| <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> |
| <!--*********************************************************** |
| * |
| * 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 |
| * |
| * Unless required by applicable law or agreed to in writing, |
| * software distributed under the License is distributed on an |
| * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY |
| * KIND, either express or implied. See the License for the |
| * specific language governing permissions and limitations |
| * under the License. |
| * |
| ***********************************************************--> |
| <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 |
| 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, wether it has to be loaded |
| ' or wether it is already on the desktop. |
| ' If the parameter bDisposable is set to False then then 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 ist 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 ist 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 over in Url-scription |
| ' The return-Value is in Urlscription |
| 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", "com") Then |
| ProductName = GetProductName() |
| sError = GetResText(1006) |
| 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, ShortDescription as String) as boolean |
| On Error Goto ErrorOcurred |
| oResSrv = createUnoService( "com.sun.star.resource.VclStringResourceLoader" ) |
| If (IsNull(oResSrv)) then |
| InitResources = FALSE |
| MsgBox( Description & ": No resource loader found", 16, GetProductName()) |
| Else |
| InitResources = TRUE |
| oResSrv.FileName = ShortDescription |
| End If |
| Exit Function |
| ErrorOcurred: |
| Dim nSolarVer |
| InitResources = FALSE |
| nSolarVer = GetSolarVersion() |
| MsgBox("Resource file missing (" & ShortDescription & trim(str(nSolarVer)) + "*.res)", 16, GetProductName()) |
| Resume CLERROR |
| CLERROR: |
| End Function |
| |
| |
| Function GetResText( nID as integer ) As string |
| On Error Goto ErrorOcurred |
| If Not IsNull(oResSrv) Then |
| GetResText = oResSrv.getString( nID ) |
| Else |
| GetResText = "" |
| End If |
| Exit Function |
| ErrorOcurred: |
| GetResText = "" |
| MsgBox("Resource with ID =" + str( nID ) + " 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 ist passed over |
| ' 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 over 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 Integer |
| 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 |
| |
| |
| Function GetLocale(sLanguage as String, sCountry as String) |
| Dim oLocale as New com.sun.star.lang.Locale |
| oLocale.Language = sLanguage |
| oLocale.Country = sCountry |
| GetLocale = oLocale |
| 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("", "com") Then |
| Select Case sType |
| Case "swriter" |
| ErrMsg = GetResText(1001) |
| Case "scalc" |
| ErrMsg = GetResText(1002) |
| Case "simpress" |
| ErrMsg = GetResText(1003) |
| Case "sdraw" |
| ErrMsg = GetResText(1004) |
| Case "smath" |
| ErrMsg = GetResText(1005) |
| 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> |