|
Server : Apache/2.4.43 (Win64) OpenSSL/1.1.1g PHP/7.4.6 System : Windows NT USER-PC 6.1 build 7601 (Windows 7 Professional Edition Service Pack 1) AMD64 User : User ( 0) PHP Version : 7.4.6 Disable Function : NONE Directory : C:/Program Files (x86)/OpenOffice 4/share/basic/Tools/ |
<?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>