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