mirror of
https://gitee.com/kekingcn/file-online-preview.git
synced 2026-03-17 06:33:50 +08:00
优化项目结构、优化 maven 结构
This commit is contained in:
chenkailing
837
office-plugin/windows-office/share/basic/Tools/Misc.xba
Normal file
837
office-plugin/windows-office/share/basic/Tools/Misc.xba
Normal file
@@ -0,0 +1,837 @@
|
||||
<?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>
|
||||
Reference in New Issue
Block a user