diff options
Diffstat (limited to 'wizards/source/tools/Misc.xba')
| -rw-r--r-- | wizards/source/tools/Misc.xba | 821 |
1 files changed, 0 insertions, 821 deletions
diff --git a/wizards/source/tools/Misc.xba b/wizards/source/tools/Misc.xba deleted file mode 100644 index faa0f802f..000000000 --- a/wizards/source/tools/Misc.xba +++ /dev/null @@ -1,821 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> -<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 -Dim xResource as Object -Dim aArgs(0) as String - On Error Goto ErrorOcurred - aArgs(0) = ShortDescription - oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider") - xResource = getProcessServiceManager().createInstanceWithArguments( "org.libreoffice.resource.ResourceIndexAccess", aArgs() ) - If (IsNull(xResource)) then - InitResources = FALSE - MsgBox("could not initialize ResourceIndexAccess") - Else - InitResources = TRUE - oResSrv = xResource.getByName( "String" ) - 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.getByIndex( 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> |