REM 10er Test const sSWLogFileName = "swlog.dat", sSCLogFileName = "sclog.dat" const sSDLogFileName = "sdlog.dat", sSMathLogFileName = "smalog.dat" const sSImDLogFileName = "simlog.dat", sSChartLogFileName = "schlog.dat" const sSHptLogFileName = "shptlog.dat", sSMessageLogFileName = "smeslog.dat" const sSDrawLogFileName = "sdrwlog.dat", sJavaLogFileName = "javalog.dat" const sSDBLogFileName = "dblog.dat", sExtLogFileName = "extlog.dat" const sLogFileName = "log.dat" const cTempFileName = "ttt" const cMessageSaveOpen8Doc = "Save/Open open Documents (8.0)" const cMessageSaveOpenXMLDoc = "Save/Open Document XML (6/7)" const cMessageSaveOpen50Doc = "Save/Open Document 5.0" const cMessageNewDoc = "New Document" const cMessageCloseDoc = "Close Document" const cMessageCutObj = "Cut Object" const cMessagePasteObj = "Paste Object" Global sWorkPath$ Global sWorkPathURL$ Global FileChannel% Global MainFileChannel% Sub Main call TestAllDocs() end Sub Sub DeleteAllSavedFiles() Dim sFileName as String sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmWriter) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmCalc) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmImpress) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmDraw) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmHyperText) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmWriter or cFltXML) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmCalc or cFltXML) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmImpress or cFltXML) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmDraw or cFltXML) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmWriter or cFlt50) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmCalc or cFlt50) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmImpress or cFlt50) If FileExists (sFileName) then Kill (sFileName) End If sFileName = sWorkPath+cTempFileName+"."+GetDocEndings(frmDraw or cFlt50) If FileExists (sFileName) then Kill (sFileName) End If End Sub Sub DeleteAllLogFiles() If FileExists (sWorkPath+sLogFileName) then Kill (sWorkPath+sLogFileName) End If If FileExists (sWorkPath+sSWLogFileName) then Kill (sWorkPath+sSWLogFileName) End If If FileExists (sWorkPath+sSCLogFileName) then Kill (sWorkPath+sSCLogFileName) End If If FileExists (sWorkPath+sSDLogFileName) then Kill (sWorkPath+sSDLogFileName) End If If FileExists (sWorkPath+sSMathLogFileName) then Kill (sWorkPath+sSMathLogFileName) End If If FileExists (sWorkPath+sSImDLogFileName) then Kill (sWorkPath+sSImDLogFileName) End If If FileExists (sWorkPath+sSChartLogFileName) then Kill (sWorkPath+sSChartLogFileName) End If If FileExists (sWorkPath+sSHptLogFileName) then Kill (sWorkPath+sSHptLogFileName) End If If FileExists (sWorkPath+sSMessageLogFileName) then Kill (sWorkPath+sSMessageLogFileName) End If If FileExists (sWorkPath+sSDrawLogFileName) then Kill (sWorkPath+sSDrawLogFileName) End If If FileExists (sWorkPath+sJavaLogFileName) then Kill (sWorkPath+sJavaLogFileName) End If If FileExists (sWorkPath+sSDBLogFileName) then Kill (sWorkPath+sSDBLogFileName) End If If FileExists (sWorkPath+sExtLogFileName) then Kill (sWorkPath+sExtLogFileName) End If end Sub Function OpenLogDat (sFileName as String) as Integer Dim LocaleFileChannel% If FileExists (sWorkPath+sFileName) then Kill (sWorkPath+sFileName) End If LocaleFileChannel% = Freefile Open sWorkPath+sFileName For Output As LocaleFileChannel% OpenLogDat = LocaleFileChannel% end Function Function GetWorkPath as string sTemp = "$(userpath)/temp/" GetWorkPath = CreateUnoService("com.sun.star.config.SpecialConfigManager").SubstituteVariables(sTemp) End Function Function GetWorkURL as string sTemp = "$(userurl)/temp/" GetWorkURL = CreateUnoService("com.sun.star.config.SpecialConfigManager").SubstituteVariables(sTemp) End Function Function GetSystem (sTmpWorkPath as string) as string GetSystem = "" if InStr (sTmpWorkPath, ":") then GetSystem = "windows" else GetSystem = "unix" End If end Function Function ConvertPathToWin (sTmpWorkPath as string) as string for i%=1 to Len(sTmpWorkPath) sTemp = Mid (sTmpWorkPath, i%, 1) if sTemp = "/" then sTmpWorkPath = Left (sTmpWorkPath, i%-1) + "\" + Right (sTmpWorkPath, Len(sTmpWorkPath)-i%) else if sTemp = "|" then sTmpWorkPath = Left (sTmpWorkPath, i%-1) + ":" + Right (sTmpWorkPath, Len(sTmpWorkPath)-i%) end If end If next i% ConvertPathToWin = sTmpWorkPath end Function Sub TestAllDocs() DIM sDocURL as String, sDocPath as String DIM nStrPos as Long sWorkPath = GetWorkPath sWorkPathURL = GetWorkURL if GetSystem (sWorkPath) = "windows" then sWorkPath = ConvertPathToWin (sWorkPath) end if 'search ExtensionURL sDocURL = gOutPutDoc.URL CompatibilityMode(true) nStrPos = InStrRev (sDocURL, "/" ) CompatibilityMode(false) sExtensionURL = Left (sDocURL, nStrPos) call DeleteAllSavedFiles() call DeleteAllLogFiles() MainFileChannel = OpenLogDat (sLogFileName) call WriteTestSequence (MainFileChannel) if bMakeWriterTest then call MakeDocTest (frmWriter) end if if bMakeCalcTest then call MakeDocTest (frmCalc) end if if bMakeImpressTest then call MakeDocTest (frmImpress) end if if bMakeDrawTest then call MakeDocTest (frmDraw) end if if bMakeHTMLTest then call MakeDocTest (frmHyperText) end if if bMakeChartTest then call MakeChartTest (frmChart) end if if bMakeMathTest then call MakeNewDoc (frmMath) end if if bMakeJavaTest then call TestJava (frmJava) end if if bMakeDBTest then call Test_DB.TestDB (frmDataBase) end if if bMakeExtensionTest then call Test_Ext.TestExtensions (frmExtension) end if Close #MainFileChannel end Sub Sub WriteTestSequence (FileChannel as integer) Print #FileChannel, "Sequence of testing" if bMakeWriterTest then WriteTests ("writer : ", true, FileChannel) end if if bMakeCalcTest then WriteTests ("calc : ", true, FileChannel) end if if bMakeImpressTest then WriteTests ("impress : ", true, FileChannel) end if if bMakeDrawTest then WriteTests ("draw : ", true, FileChannel) end if if bMakeHTMLTest then WriteTests ("HTML : ", true, FileChannel) end if if bMakeChartTest then WriteTests ("chart : ", false, FileChannel) end if if bMakeMathTest then WriteTests ("math : ", false, FileChannel) end if if bMakeJavaTest then WriteTests ("Java : ", false, FileChannel) end if if bMakeDBTest then WriteDBTests ("Database : ", FileChannel) end if if bMakeExtensionTest then WriteExtensionTests ("Extension : ", FileChannel) end if Print #FileChannel end Sub Sub WriteTests (sText as string, bTestAll as boolean, nFileChannel as integer) Dim sWriteStr as string sWriteStr = sText sWriteStr = sWriteStr + "new" if bTestAll then if bMakeCutTest then sWriteStr = sWriteStr + ", cut" end if if bMakePasteTest then sWriteStr = sWriteStr + ", paste" end if if bMakeSaveOpen8Test then sWriteStr = sWriteStr + ", save 8.0" end if if bMakeSaveOpenXMLTest then sWriteStr = sWriteStr + ", save XML" end if if bMakeSaveOpen50Test then sWriteStr = sWriteStr + ", save 5.0" end if if bMakeSaveOpen8Test then sWriteStr = sWriteStr + ", open 8.0" end if if bMakeSaveOpenXMLTest then sWriteStr = sWriteStr + ", open XML" end if if bMakeSaveOpen50Test then sWriteStr = sWriteStr + ", open 5.0" end if end if sWriteStr = sWriteStr + ", close" Print #nFileChannel, sWriteStr end Sub Sub WriteDBTests (sText as string, nFileChannel as integer) Dim sWriteStr as string sWriteStr = sText sWriteStr = sWriteStr + "open / services" sWriteStr = sWriteStr + ", insert" sWriteStr = sWriteStr + ", delete" sWriteStr = sWriteStr + ", seek" sWriteStr = sWriteStr + ", close" Print #nFileChannel, sWriteStr end Sub Sub WriteExtensionTests (sText as string, nFileChannel as integer) Dim sWriteStr as string sWriteStr = sText sWriteStr = sWriteStr + "services" sWriteStr = sWriteStr + ", install" sWriteStr = sWriteStr + ", uninstall" Print #nFileChannel, sWriteStr end Sub Sub MakeDocTest (FilterType as Integer) Dim oDoc as Object Dim sFileNameXML$, sFileName50$, sFileName8$ Dim bError as Boolean Dim nCurrentAction as Integer On Local Error GoTo DOCTESTERROR nCurrentAction = cLogfileFailed FileChannel% = OpenLogDat (GetLogFileName(FilterType)) nCurrentAction = cDocNew oDoc = LoadDoc ("private:factory/" + GetDocFilter(FilterType or cFltNewDoc)) LogState (not IsNull (oDoc), GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageNewDoc, FileChannel) LogState (not IsNull (oDoc), GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageNewDoc, MainFileChannel) SetStatus (FilterType, cDocNew, not IsNull (oDoc)) if not IsNull (oDoc) then nCurrentAction = cDocCut call CutAndPaste(FilterType, oDoc) ' bError = oDoc.CurrentController.frame.close nCurrentAction = cDocSaveOpen8 if bMakeSaveOpen8Test and IsFilterAvailable (FilterType or cFlt8) then sFileName8 = sWorkPathURL+cTempFileName+"."+GetDocEndings(FilterType or cFlt8) SaveDoc (sFileName8, oDoc, GetDocFilter(FilterType or cFlt8)) end if nCurrentAction = cDocSaveOpenXML if bMakeSaveOpenXMLTest and IsFilterAvailable (FilterType or cFltXML) then sFileNameXML = sWorkPathURL+cTempFileName+"."+GetDocEndings(FilterType or cFltXML) SaveDoc (sFileNameXML, oDoc, GetDocFilter(FilterType or cFltXML)) end if nCurrentAction = cDocSaveOpen50 if bMakeSaveOpen50Test and IsFilterAvailable (FilterType or cFlt50) then sFileName50 = sWorkPathURL+cTempFileName+"."+GetDocEndings(FilterType or cFlt50) SaveDoc (sFileName50, oDoc, GetDocFilter(FilterType or cFlt50)) end if ' oDoc.dispose nCurrentAction = cDocClose oDoc.close (true) ' bError = true ' nur zum ¦bergang, weil bError = oDoc.CurrentController.frame.close nicht geht ' LogState (bError, GetDocFilter(FilterType)+" "+ cMessageCloseDoc, FileChannel) ' LogState (bError, GetDocFilter(FilterType)+" "+ cMessageCloseDoc, MainFileChannel) ' SetStatus (FilterType, cDocClose, bError) nCurrentAction = cDocSaveOpen8 if bMakeSaveOpen8Test and IsFilterAvailable (FilterType or cFlt8) then oDoc = LoadDoc (sFileName8) ' oDoc = Documents.open(sFileName) LogState (not IsNull (oDoc),GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageSaveOpen8Doc, FileChannel) LogState (not IsNull (oDoc),GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageSaveOpen8Doc, MainFileChannel) SetStatus (FilterType, cDocSaveOpen8, not IsNull (oDoc)) if not IsNull (oDoc) then ' oDoc.dispose nCurrentAction = cDocClose oDoc.close (true) end If end if nCurrentAction = cDocSaveOpenXML if bMakeSaveOpenXMLTest and IsFilterAvailable (FilterType or cFltXML) then oDoc = LoadDoc (sFileNameXML) ' oDoc = Documents.open(sFileName) LogState (not IsNull (oDoc),GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageSaveOpenXMLDoc, FileChannel) LogState (not IsNull (oDoc),GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageSaveOpenXMLDoc, MainFileChannel) SetStatus (FilterType, cDocSaveOpenXML, not IsNull (oDoc)) if not IsNull (oDoc) then ' oDoc.dispose nCurrentAction = cDocClose oDoc.close (true) end If end if nCurrentAction = cDocSaveOpen50 if bMakeSaveOpen50Test and IsFilterAvailable (FilterType or cFlt50) then oDoc = LoadDoc (sFileName50) ' oDoc = Documents.open(sFileName) LogState (not IsNull (oDoc),GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageSaveOpen50Doc, FileChannel) LogState (not IsNull (oDoc),GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageSaveOpen50Doc, MainFileChannel) SetStatus (FilterType, cDocSaveOpen50, not IsNull (oDoc)) if not IsNull (oDoc) then ' oDoc.dispose nCurrentAction = cDocClose oDoc.close (true) end If end if end If Print #FileChannel, "---" Close #FileChannel% Exit Sub ' Without error DOCTESTERROR: If (nCurrentAction = cLogfileFailed) then SetStatus (FilterType, cDocNew, False) Exit Sub else LogState (False, GetDocFilter(FilterType or cFltNewDoc)+" "+ GetErrorMessage(nCurrentAction), FileChannel) LogState (False, GetDocFilter(FilterType or cFltNewDoc)+" "+ GetErrorMessage(nCurrentAction), MainFileChannel) SetStatus (FilterType, nCurrentAction, False) Close #FileChannel% End If Exit Sub ' With error End Sub Sub MakeNewDoc (FilterType as Integer) DIM oDoc as Object Dim bError as Boolean Dim nCurrentAction as Integer On Local Error GoTo DOCTESTERROR2 nCurrentAction = cLogfileFailed FileChannel% = OpenLogDat (GetLogFileName(FilterType)) nCurrentAction = cDocNew ' oDoc = Documents.Add(GetDocFilter(FilterType)) oDoc = LoadDoc ("private:factory/" + GetDocFilter(FilterType or cFltNewDoc)) LogState (not IsNull (oDoc), GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageNewDoc, FileChannel) LogState (not IsNull (oDoc), GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageNewDoc, MainFileChannel) SetStatus (FilterType, cDocNew, not IsNull (oDoc)) if not IsNull (oDoc) then nCurrentAction = cDocClose ' oDoc.dispose oDoc.close (true) ' bError = true ' nur zum ¦bergang, weil bError = oDoc.CurrentController.frame.close nicht geht ' LogState (bError, GetDocFilter(FilterType)+" "+ cMessageCloseDoc, FileChannel) ' LogState (bError, GetDocFilter(FilterType)+" "+ cMessageCloseDoc, MainFileChannel) ' SetStatus (FilterType, cDocClose, bError) end If Print #FileChannel, "---" Close #FileChannel% Exit Sub ' Without error DOCTESTERROR2: If (nCurrentAction = cLogfileFailed) then SetStatus (FilterType, cDocNew, False) Exit Sub else LogState (False, GetDocFilter(FilterType or cFltNewDoc)+" "+ GetErrorMessage(nCurrentAction), FileChannel) LogState (False, GetDocFilter(FilterType or cFltNewDoc)+" "+ GetErrorMessage(nCurrentAction), MainFileChannel) SetStatus (FilterType, nCurrentAction, False) Close #FileChannel% End If Exit Sub ' With error End Sub Sub MakeChartTest (FilterType as Integer) Dim oCharts as Object Dim oDoc as Object Dim oRange(0) as New com.sun.star.table.CellRangeAddress Dim oRect as New com.sun.star.awt.Rectangle const cChartName="TestChart" Dim bError as Boolean Dim nCurrentAction as Integer On Local Error GoTo CHARTTESTERROR nCurrentAction = cLogfileFailed FileChannel% = OpenLogDat (GetLogFileName(FilterType)) nCurrentAction = cDocNew oDoc = LoadDoc ("private:factory/" + GetDocFilter(frmCalc or cFltNewDoc)) if not IsNull (oDoc) then oCharts = oDoc.sheets(0).Charts oCharts.AddNewByName (cChartName, oRect, oRange(), true, true) bError=oCharts.HasByName(cChartName) LogState (bError, GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageNewDoc, FileChannel) LogState (bError, GetDocFilter(FilterType or cFltNewDoc)+" "+ cMessageNewDoc, MainFileChannel) SetStatus (FilterType, cDocNew, bError) ' oDoc.dispose nCurrentAction = cDocClose oDoc.close (true) else LogState (not IsNull (oDoc), GetDocFilter(frmCalc or cFltNewDoc)+" "+ cMessageNewDoc, FileChannel) LogState (not IsNull (oDoc), GetDocFilter(frmCalc or cFltNewDoc)+" "+ cMessageNewDoc, MainFileChannel) SetStatus (frmCalc, cDocNew, not IsNull (oDoc)) End if Print #FileChannel, "---" Close #FileChannel% Exit Sub ' Without error CHARTTESTERROR: If (nCurrentAction = cLogfileFailed) then SetStatus (FilterType, cDocNew, False) Exit Sub else LogState (False, GetDocFilter(FilterType or cFltNewDoc)+" "+ GetErrorMessage(nCurrentAction), FileChannel) LogState (False, GetDocFilter(FilterType or cFltNewDoc)+" "+ GetErrorMessage(nCurrentAction), MainFileChannel) SetStatus (FilterType, nCurrentAction, False) Close #FileChannel% End If Exit Sub ' With error End Sub Sub LogState (bState as Boolean, sText as String, nLocaleFileChannel as integer) if bState then Print #nLocaleFileChannel, sText+" -> ok" else Print #nLocaleFileChannel, sText+" -> error" end If end Sub Function GetDocEndings (DocType as Integer) as String Select Case ( DocType ) case frmWriter or cFlt8 GetDocEndings = "odt" ' Textdokument case frmCalc or cFlt8 GetDocEndings = "ods" 'Tabellendokument case frmImpress or cFlt8 GetDocEndings = "odp" 'PrÕsentation case frmDraw or cFlt8 GetDocEndings = "odg" 'Zeichen case frmHyperText, frmHyperText or cFlt50, frmHyperText or cFltXML GetDocEndings = "html" 'Hypertext-Dokument case frmWriter or cFlt50 GetDocEndings = "sdw" ' Textdokument 5.0 case frmCalc or cFlt50 GetDocEndings = "sdc" 'Tabellendokument 5.0 case frmImpress or cFlt50 GetDocEndings = "sdd" 'PrÕsentation 5.0 case frmDraw or cFlt50 GetDocEndings = "sda" 'Zeichen 5.0 case frmWriter or cFltXML GetDocEndings = "sxw" ' Textdokument case frmCalc or cFltXML GetDocEndings = "sxc" 'Tabellendokument case frmImpress or cFltXML GetDocEndings = "sxi" 'PrÕsentation case frmDraw or cFltXML GetDocEndings = "sxd" 'Zeichen case else GetDocEndings = "" end Select end Function Function GetDocFilter (DocType as Integer) as String Select Case ( DocType ) case frmWriter or cFlt8 GetDocFilter = "writer8" ' Textdokument case frmCalc or cFlt8 GetDocFilter = "calc8" 'Tabellendokument case frmImpress or cFlt8 GetDocFilter = "impress8" 'Präsentation case frmDraw or cFlt8 GetDocFilter = "draw8" 'Zeichen case frmMath or cFlt8 GetDocFilter = "math8" 'Formel case frmWriter or cFltXML GetDocFilter = "StarOffice XML (Writer)" ' Textdokument case frmCalc or cFltXML GetDocFilter = "StarOffice XML (Calc)" 'Tabellendokument case frmImpress or cFltXML GetDocFilter = "StarOffice XML (Impress)" 'Präsentation case frmDraw or cFltXML GetDocFilter = "StarOffice XML (Draw)" 'Zeichen case frmMath or cFltXML GetDocFilter = "StarOffice XML (Math)" 'Formel case frmHyperText, frmHyperText or cFlt50, frmHyperText or cFltXML GetDocFilter = "HTML" 'Hypertext-Dokument case frmWriter or cFlt50 GetDocFilter = "StarWriter 5.0" ' Textdokument 5.0 case frmCalc or cFlt50 GetDocFilter = "StarCalc 5.0" 'Tabellendokument 5.0 case frmImpress or cFlt50 GetDocFilter = "StarImpress 5.0" 'Präsentation 5.0 case frmDraw or cFlt50 GetDocFilter = "StarDraw 5.0" 'Zeichen 5.0 case frmMath or cFlt50 GetDocFilter = "StarMath 5.0" 'Formel 5.0 case frmWriter or cFltNewDoc GetDocFilter = "swriter" ' Textdokument case frmCalc or cFltNewDoc GetDocFilter = "scalc" 'Tabellendokument case frmMessage or cFltNewDoc GetDocFilter = "Message" 'Nachricht case frmImpress or cFltNewDoc GetDocFilter = "simpress" 'Präsentation case frmDraw or cFltNewDoc GetDocFilter = "sdraw" 'Zeichen case frmMath or cFltNewDoc GetDocFilter = "smath" 'Formel case frmImage or cFltNewDoc GetDocFilter = "simage" 'Bild case frmHyperText or cFltNewDoc GetDocFilter = "swriter/web" 'Hypertext-Dokument case frmChart or cFltNewDoc GetDocFilter = "schart" 'Diagramm case else GetDocFilter = "" end Select end Function Function GetLogFileName (DocType as Integer) as String Select Case ( DocType ) case frmWriter GetLogFileName = sSWLogFileName ' Textdokument case frmCalc GetLogFileName = sSCLogFileName 'Tabellendokument case frmMessage GetLogFileName = sSMessageLogFileName 'Nachricht case frmImpress GetLogFileName = sSDLogFileName 'PrÕsentation case frmDraw GetLogFileName = sSDrawLogFileName 'Zeichnen case frmMath GetLogFileName = sSMathLogFileName 'Formel case frmImage GetLogFileName = sSImDLogFileName 'Bild case frmHyperText GetLogFileName = sSHptLogFileName 'Hypertext-Dokument case frmChart GetLogFileName = sSChartLogFileName 'Diagramm case frmJava GetLogFileName = sJavaLogFileName 'Java case frmDataBase GetLogFileName = sSDBLogFileName 'Database case frmExtension GetLogFileName = sExtLogFileName 'Extension case else GetLogFileName = "" end Select end Function Function GetErrorMessageOnAction (nAction as Integer) as String Select Case ( nAction ) case cDocNew GetErrorMessageOnAction = cMessageNewDoc case cDocCut GetErrorMessageOnAction = cMessageCutObj case cDocPaste GetErrorMessageOnAction = cMessagePasteObj case cDocSaveOpen8 GetErrorMessageOnAction = cMessageSaveOpen8Doc case cDocSaveOpenXML GetErrorMessageOnAction = cMessageSaveOpenXMLDoc case cDocSaveOpen50 GetErrorMessageOnAction = cMessageSaveOpen50Doc case cDocClose GetErrorMessageOnAction = cMessageCloseDoc case else GetErrorMessageOnAction = "" end Select end Function Function IsFilterAvailable (FilterType as Integer) as boolean IsFilterAvailable = true if ((FilterType = (frmHyperText or cFlt50)) or (FilterType = (frmHyperText or cFltXML))) then IsFilterAvailable = false end if End Function Function TestJava (FilterType as Integer) as boolean Dim oObj as Object FileChannel% = OpenLogDat (GetLogFileName(FilterType)) oObj = createUnoService(cUnoJavaLoader) LogState (not IsNull (oObj), "Java "+ cMessageNewDoc, FileChannel) LogState (not IsNull (oObj), "Java "+ cMessageNewDoc, MainFileChannel) SetStatus (FilterType, cDocNew, not IsNull (oObj)) Print #FileChannel, "---" Close #FileChannel% TestJava = not IsNull (oObj) End Function Sub CutAndPaste (DocType as Integer, oDoc as Object) Dim sText as String Dim oWin as Object Dim oText as Object Dim oView as Object Dim bCutState as boolean, bPasteState as boolean Select Case ( DocType ) case frmWriter Dim oCursor as Object sText = "AutomaticText" oText = oDoc.GetText oCursor = oText.CreateTextCursor oText.InsertString(oCursor, sText, true) ' Cursor selektiert den Text oView = oDoc.getCurrentController oView.Select(oCursor) if bMakeCutTest then call CutText (oDoc) if oText.GetString = "" Then bCutState = True else bCutState = False end If SetStatus (DocType, cDocCut, bCutState) LogState (bCutState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessageCutObj, FileChannel) LogState (bCutState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessageCutObj, MainFileChannel) end if if bMakePasteTest and bMakeCutTest then call PasteText (oDoc) if oText.GetString = sText Then bPasteState = True else bPasteState = False end If SetStatus (DocType, cDocPaste, bPasteState) LogState (bPasteState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessagePasteObj, FileChannel) LogState (bPasteState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessagePasteObj, MainFileChannel) end if case frmCalc DIM oCell as Object sText = "AutomaticText" oCell = oDoc.Sheets(0).GetCellByPosition(0, 0) oCell.String = sText oView = oDoc.getCurrentController oView.Select(oCell) if bMakeCutTest then call CutText (oDoc) if oCell.String = "" Then bCutState = True else bCutState = False end If SetStatus (DocType, cDocCut, bCutState) LogState (bCutState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessageCutObj, FileChannel) LogState (bCutState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessageCutObj, MainFileChannel) end if if bMakePasteTest and bMakeCutTest then call PasteText (oDoc) if oCell.String = sText Then bPasteState = True else bPasteState = False end If SetStatus (DocType, cDocPaste, bPasteState) LogState (bPasteState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessagePasteObj, FileChannel) LogState (bPasteState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessagePasteObj, MainFileChannel) end if case frmMessage case frmImpress, frmDraw Dim oPage as Object Dim oRect as Object Dim xSize as Object Dim xPoint as Object Dim bObjState as Boolean xSize = CreateUnoStruct ("com.sun.star.awt.Size") xPoint = CreateUnoStruct ("com.sun.star.awt.Point") xSize.Width = 2000 xSize.Height = 2000 xPoint.x = 10000 xPoint.y = 10000 oPage = oDoc.DrawPages(0) if DocType = frmImpress Then oPage.Layout = 20 ' set page layot to none end If oRect = oDoc.CreateInstance("com.sun.star.drawing.RectangleShape") oRect.Size = xSize oRect.Position = xPoint oPage.add(oRect) oView = oDoc.getCurrentController oView.Select(oRect) ' Prüft ob überhaupt ein Object angelegt wurde if oPage.count = 1 Then bObjState = True else bObjState = False end If if bMakeCutTest then call CutText (oDoc) if (oPage.count = 0) and bObjState Then bCutState = True else bCutState = False end If SetStatus (DocType, cDocCut, bCutState) LogState (bCutState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessageCutObj, FileChannel) LogState (bCutState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessageCutObj, MainFileChannel) end if wait (1000) 'wait after cut if bMakePasteTest and bMakeCutTest then call PasteText (oDoc) if (oPage.count = 1) and bObjState Then bPasteState = True else bPasteState = False end If SetStatus (DocType, cDocPaste, bPasteState) LogState (bPasteState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessagePasteObj, FileChannel) LogState (bPasteState, GetDocFilter(DocType or cFltNewDoc)+" "+ cMessagePasteObj, MainFileChannel) end if case frmMath case frmImage case frmHyperText case frmChart end Select end Sub Sub LoadLibrary( LibName as String ) dim args(1) dim arg as new com.sun.star.beans.PropertyValue arg.Name = "LibraryName" arg.Value = LibName args(0) = arg dim url as new com.sun.star.util.URL dim trans as object trans = createUnoService("com.sun.star.util.URLTransformer" ) url.Complete = "slot:6517" trans.parsestrict( url ) dim disp as object disp = StarDesktop.currentFrame.queryDispatch( url, "", 0 ) disp.dispatch( url, args() ) End Sub Sub LoadDoc (DocName as String) as Object dim trans as object trans = createUnoService("com.sun.star.util.URLTransformer" ) url = createUnoStruct("com.sun.star.util.URL" ) url.Complete = DocName if Left(DocName, 5 ) <> "file:" then trans.parsestrict( url ) endif Dim aPropArray(0) as Object aPropArray(0) = CreateUnoStruct("com.sun.star.beans.PropertyValue") aPropArray(0).Name = "OpenFlags" aPropArray(0).Value = "S" dim doc as object dim noargs() doc = StarDesktop.loadComponentFromURL( url.Complete, "_blank", 0, aPropArray() ) ' XModel LoadDoc = doc End Sub Sub SaveDoc (DocName as String, oDoc as Object, sFilterName as string ) dim trans as object trans = createUnoService("com.sun.star.util.URLTransformer" ) url = createUnoStruct("com.sun.star.util.URL" ) url.Complete = DocName if Left(DocName, 5 ) <> "file:" then trans.parsestrict( url ) endif if not (sFilterName = "") then Dim aPropArray(0) as Object aPropArray(0) = CreateUnoStruct("com.sun.star.beans.PropertyValue") aPropArray(0).Name = "FilterName" aPropArray(0).Value = sFilterName oDoc.storeAsURL( url.Complete, aPropArray() ) else MessageBox "Filtername is unknown!" end if end Sub