'encoding UTF-8 Do not remove or change this line! '************************************************************************** '* DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. '* '* Copyright 2008 by Sun Microsystems, Inc. '* '* OpenOffice.org - a multi-platform office productivity suite '* '* $RCSfile: t_tools1.inc,v $ '* '* $Revision: 1.1 $ '* '* last change: $Author: jsi $ $Date: 2008-06-13 10:27:11 $ '* '* This file is part of OpenOffice.org. '* '* OpenOffice.org is free software: you can redistribute it and/or modify '* it under the terms of the GNU Lesser General Public License version 3 '* only, as published by the Free Software Foundation. '* '* OpenOffice.org is distributed in the hope that it will be useful, '* but WITHOUT ANY WARRANTY; without even the implied warranty of '* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the '* GNU Lesser General Public License version 3 for more details '* (a copy is included in the LICENSE file that accompanied this code). '* '* You should have received a copy of the GNU Lesser General Public License '* version 3 along with OpenOffice.org. If not, see '* '* for a copy of the LGPLv3 License. '* '/************************************************************************ '* '* owner : joerg.sievers@sun.com '* '* short description : Tools (1) '* '*************************************************************************************** '* ' #1 GetClipboardText 'Returns the correct clipboard text (also if there is a 'RETURN' at it's end. ' #1 hDoubleClickInList ' #0 hMouseClick ' #1 wielange ' #1 sleep ' #1 WaitInSek ' #1 WaitInMilliSek ' #1 DialogTest 'Creates snapshots ' #0 DialogTest2 'Creates snapshots ' #1 hFindeImDokument 'Searches for a string with the 'Search&Replace'-dlg in a document. ' #1 hFindeMehrImDokument 'Same as 'hFindeImDokument' but needs an integer how often the search-phrase must be found until the boolean gives TRUE back. ' #1 ErgebnisSchreiben ' #1 TextInDatei ' #1 hGetUIFiltername 'Extracts the UI filtername from configuration. ' #1 hGetFilternameExtension 'Extracts the filtername extension from configuration. ' #1 TrimTab 'trimming strings ' #1 lTrimTab 'trimming strings ' #1 rTrimTab 'trimming strings ' #1 TrimString 'Cuts all ASCII characters which are defined by a parameter (e.g. 32 space will be deleted) ' #1 ActiveDeactivateAsianSupport 'Acivates/Deactivates the Asian support in StarOffice ' #1 ActiveDeactivateCTLSupport 'Acivates/Deactivates the CTL support in StarOffice ' #1 GetDecimalSeperator 'Reads from Tools / Options the used . or , which is being used as seperator ' #1 sResetTheOffice 'Save language information - throw away user directory - restore language information '* '\************************************************************************************* function GetClipboardText as string '/// Returns the correct clipboard text (also if there is a 'RETURN' at it's end. Dim i% : Dim CBText$ Dim Zwischen$ wait 500 GetClipboardText = "" CBText$ = GetClipboard if CBText$ = "" then GetClipboardText = "" exit function end if if asc ( Right( CBText$, 1 )) = 10 then Zwischen$ = Mid( CBText$, 1, len(CBText$)-1 ) if Zwischen$ <> "" then if asc ( Right( Zwischen$, 1 )) = 13 then GetClipboardText = Mid( Zwischen$, 1, len(Zwischen$)-1 ) else GetClipboardText = Zwischen$ end if else GetClipboardText = Zwischen$ end if else if asc ( Right( CBText$, 1 )) = 13 then Zwischen$ = Mid( CBText$, 1, len(CBText$)-1 ) if asc ( Right( Zwischen$, 1 )) = 10 then GetClipboardText = Mid( Zwischen$, 1, len(Zwischen$)-1 ) else GetClipboardText = Zwischen$ end if else GetClipboardText = CBText$ end if end if end function '------------------------------------------------------------------------- function hDoubleClickInList ( window, Selektion as String, optional bFocus as boolean ) as Boolean '/// hDoubleClickInList '///+ Makes a double click onto an entry in a list (tested only in style lists) '///+ window: name of list ///' '///+ selektion: string to find in list ///' '///+ bFocus: TRUE: activate the window with mouseclick before leaving ///' '///+ ReturnValue: if found: TRUE; else FALSE ///' Dim i as Integer Dim AlterWert as String Dim NeuerWert as String NeuerWert = "!=! !=!" ' init with dummy value window.TypeKeys "" if window.gettext <> Selektion then for i=1 to 100 step 2 window.MouseDown 5, i +1 window.MouseUp 5, i +1 AlterWert = window.GetText window.TypeKeys "" NeuerWert = Window.GetText window.TypeKeys "" if AlterWert = Selektion then window.MouseDown 5, i +1 window.MouseUp 5, i +1 if Window.GetText = Selektion then ' catch if had any effects window.MouseDoubleClick 5, i +1 if (isMissing (bFocus) = FALSE) then ' if optional parameter provided window.MouseDown 5, i +1 window.MouseUp 5, i +1 endif i = 202 else i=0 ' start at top of list end if else if AlterWert = NeuerWert then Warnlog "'" + Selektion + "' wasn't found in list!" i = 202 else if i > 98 then i=40 ' list not at end, but scrolled end if end if next i if i < 200 OR i > 100 then hDoubleClickInList = FALSE else hDoubleClickInList = TRUE end if else window.TypeKeys "" hDoubleClickInList = TRUE endif end function '------------------------------------------------------------------------- sub hMouseClick ( window, xPos, yPos ) ' Author: Thorsten Ziehm (26.09.2000) '/// hMouseClick '///+ Do a mouse click on a named window. '/// Input: '///+ window : The object on which the mouse click should be make (document, listbox, window) '///+ xPos : x-position (relativ to the size of the window (1:100) '///+ yPos : y-position (relativ to the size of the window (1:100) window.MouseDown ( xPos, yPos ) window.MouseUp ( xPos, yPos ) end sub '------------------------------------------------------------------------- function wielange (StrtTime, optional iFormat as integer) as String ' Author: Michael Friedrichs '/// wielange '///+ Returns the time between a start- and an end timeframe. '///+ iFormat: 0: default; 1: mysql ///' Dim Zeitspanne Dim Zeitspannesek Dim Zeitspannemin Dim Zeitspanneh dim sTemp as string if isMissing(iFormat) then 'dim iFormat as integer iFormat = 0 endif Zeitspanne = Now() - StrtTime Zeitspannesek = Zeitspanne / 1.15741E-05 + 1 Zeitspanneh = Fix(Zeitspannesek / 3600) Zeitspannesek = Zeitspannesek - Zeitspanneh * 3600 Zeitspannemin = Fix(Zeitspannesek / 60) Zeitspannesek = Zeitspannesek - Zeitspannemin * 60 Zeitspannesek = Fix(Zeitspannesek) select case iFormat case 0: sTemp = "" & Zeitspanneh & "h " & Zeitspannemin & "m " & Zeitspannesek & "s" case 1: if Zeitspanneh < 10 then ' mysql format for status.inc sTemp = "0" & Zeitspanneh & ":" else sTemp = "" & Zeitspanneh & ":" end if if Zeitspannemin < 10 then sTemp = "" & sTemp & "0" & Zeitspannemin & ":" else sTemp = "" & sTemp & Zeitspannemin & ":" end if if Zeitspannesek < 10 then sTemp = "" & sTemp & "0" & Zeitspannesek else sTemp = "" & sTemp & Zeitspannesek end if case default: qaErrorLog "t_tools1.inc::wielange: optional parameter iFormat out of range!" sTemp = "" end select wielange = sTemp end function '------------------------------------------------------------------------- sub WaitInSek ( Sekunden ) ' Author: Thorsten Ziehm '/// WaitInSek '///+ Wait exactly x second(s) (using GetSystemTicks) Dim i : Dim t0 : Dim t1 t0 = GetSystemTicks() for i=1 to 10000*Sekunden t1 = GetSystemTicks() if t1-t0 > 1000*Sekunden then i=11000*Sekunden next i end sub '------------------------------------------------------------------------- sub WaitInMilliSek ( Milli ) ' Author: Thorsten Ziehm '/// WaitInMilliSek '///+ Wait exactly x millisecond(s) (using GetSystemTicks) Dim i : Dim t0 : Dim t1 t0 = GetSystemTicks() for i=1 to 1000*Milli t1 = GetSystemTicks if t1-t0 > Milli then i=1001*Milli next i end sub '------------------------------------------------------------------------- sub sleep ( i% ) '/// sleep '///+ simple sleep routine which uses seconds. ' WaitInSek ( i% ) wait i%*1000 end sub '------------------------------------------------------------------------- sub DialogTest( Window, optional iNumber as integer) '/// DialogTest '///+ Make SnapShots '/// Window : the name of the window as declared in qa/qatesttool/global/win/* '/// Optional Parameter iNumber : Number to distinguish windows which dynamical change their content but not their ID///' '///+ the number has to be provided by the testscript creator ///' Dim Ergebnis as Integer Dim Ausgabe as String Dim UndRaus as Boolean Dim sCount as string ' evaluate optional parameter if isMissing(iNumber) then 'just one picture sCount = "" else 'there will be more pictures with the same ID sCount = "_"+iNumber endif if gDasNicht=0 then ' In Place Translation Feature: not used anymore; ' The matching of the strings on the later migration step never worked. ' Just kept here for historical reasons Ausgabe = "" UndRaus = FALSE while UndRaus = FALSE Ausgabe = translate if Ausgabe <> "" OR Ausgabe <> "1" then if Left ( Ausgabe, 1 ) = "0" then Ausgabe = Right ( Ausgabe, Len( Ausgabe )- 2 ) AnhaengenAnDatei ( gOfficePath + "trans_output.txt", Ausgabe ) end if end if if Ausgabe = "1" then UndRaus = TRUE wend else ' Usual window check try if Not window.Exists(2) then Warnlog " - Window nicht existent:" + window.Name + " " + window.ID exit sub end if 'To get a history, of what windows are covered, use the following line ' AnhaengenAnDatei ( ConvertPath (gOfficePath + "user\work\wieviel.txt"), window.Name + " " + sCount + " : " + window.ID ) catch ExceptLog endcatch end if if gbSnapShot = TRUE then 'Make Screenshot from dialog and save as HelpID.bmp Dim Dummy as String, sName as String, sPicName as String 'get window ID Dummy = Window 'set filename sName = Dummy + sCount + ".bmp" 'save with respect to application and language sCapturePath = ConvertPath (gOfficePath + "user\work\screenshots"+iSprache+"\") sPicName = sCapturePath + lCase(gApplication) 'create directory if it doesn't exist if hDirectoryExists(sPicName) <> TRUE then mkdir (sPicName) end if sPicName = sPicName + sName try sleep 1 window.SnapShot( sPicName ) catch warnlog "t_tools1.inc::DialogTest Failed to save screenshot: '" + sPicName + "'" endcatch printlog sPicName end if end sub '----------------------------------------------------------- sub DialogTest2( Window, i% ) 'deprecated TBO:2006/03/16 DialogTest( Window, i% ) end sub '------------------------------------------------------------------------- function hFindeImDokument ( Passage$ , Optional A, optional bRegEx ) as boolean ' Author: Joerg Sievers (13.11.2001) '/// hFindeImDokument '/// Searches via 'Search&Replace'-Dlg in StarOffice Writer, -Clac, '///+ -HTML, -GlobalDoc for the string EXACT MATCH. '///+ Only ONE TIME and THE FIRST search phrase will be found! '/// Optional Parameter a : If you do not want a warnlog message '/// Optional Parameter bRegEx : if you look fort an regular expression Dim WhatIsIn as string Dim bSilent as boolean bSilent = NOT isMissing(a) gApplication = UCase ( gApplication ) hFindeImDokument = FALSE select case gApplication case "CALC" : Kontext "DocumentCalc" DocumentCalc.TypeKeys "" case "WRITER" : Kontext "DocumentWriter" DocumentWriter.TypeKeys "" case "NACHRICHT" : Kontext "DokumentNachrichten" DokumentNachrichten.TypeKeys "" case "HTMLDOKUMENT": Kontext "DocumentWriterWeb" DocumentWriterWeb.TypeKeys "" case "GLOBALDOC" : Kontext "DocumentMasterDoc" DocumentMasterDoc.TypeKeys "" end select SetClipboard "" EditSearchAndReplace Kontext "FindAndReplace" if SimilaritySearch.IsVisible = False then More.Click end if if MatchCase.IsChecked = False then MatchCase.Check end if if SimilaritySearch.IsChecked = TRUE then SimilaritySearch.UnCheck if NOT bSilent then warnlog "'Similarity search' checkbox was enabled! It shouldn't be the default!" endif end if if IsMissing(bRegEx) <> TRUE then RegularExpressions.Check end if SearchFor.Settext Passage$ SearchNow.Click Kontext if NOT Active.Exists(2) then Kontext "FindAndReplace" More.Click FindAndReplace.Cancel EditCopy WhatIsIn = GetClipboardText if WhatIsIn <> Passage$ then if NOT bSilent then warnlog "The search-request for '" & Passage$ & "' has been fault! (Found: '"& WhatIsIn & "')" end if else hFindeImDokument = TRUE end if else try Kontext if Active.Exists(1) then Active.OK end if if NOT bSilent then warnlog "The search-request for '" & Passage$ & "' has been fault! (Found: '"& WhatIsIn & "')" end if Kontext "FindAndReplace" if SimilaritySearch.IsVisible = False then More.Click endif if MatchCase.IsChecked then MatchCase.UnCheck endif if SimilaritySearch.IsChecked = TRUE then SimilaritySearch.UnCheck if NOT bSilent then warnlog "'Similarity search' checkbox was enabled! It shouldn't be the default!" endif end if if IsMissing(bRegEx) <> TRUE then RegularExpressions.UnCheck endif More.Click FindAndReplace.Cancel catch Active.Yes Kontext if bSilent then if Active.Exists then printlog "> "+Active.GetText endif if Active.Exists then Active.OK if NOT bSilent then warnlog "The search-request for '" & Passage$ & "' has been fault! (Found: '"& WhatIsIn & "')" endif Kontext "FindAndReplace" if SimilaritySearch.IsVisible = False then More.Click endif if MatchCase.IsChecked then MatchCase.UnCheck endif if SimilaritySearch.IsChecked = TRUE then SimilaritySearch.UnCheck if NOT bSilent then warnlog "'Similarity search' checkbox was enabled! It shouldn't be the default!" endif end if if IsMissing(bRegEx) <> TRUE then RegulaererAusdruck.UnCheck endif More.Click FindAndReplace.Cancel endcatch end if end function '------------------------------------------------------------------------- function hFindeMehrImDokument ( Passage as string , WieOft as integer ) as boolean ' Author: Joerg Sievers (26.07.2000) '/// hFindeMehrImDokument '/// Searches per 'Search&Replace'-Dlg in StarOffice Writer, -Clac, '///+-HTML, -GlobalDoc for the string EXACT MATCH. '/// You have to give the function the number how often the phrase '///+should be found in the document as an additional parameter (as integer). '/// Only when exact the number of the phrase will be found correctly '///+the function gives back TRUE. '/// see also : hFindeImDokument (TOOLS.INC) Dim i as integer gApplication = UCase ( gApplication ) hFindeMehrImDokument = FALSE select case gApplication case "CALC" : Kontext "DocumentCalc" DocumentCalc.TypeKeys "" case "WRITER" : Kontext "DocumentWriter" DocumentWriter.TypeKeys "" case "NACHRICHT" : Kontext "DokumentNachrichten" DokumentNachrichten.TypeKeys "" case "HTMLDOKUMENT": Kontext "DocumentWriter" DocumentWriter.TypeKeys "" case "GLOBALDOC" : Kontext "DocumentMasterDoc" DocumentMasterDoc.TypeKeys "" end select SetClipboard "" EditSearchAndReplace For i = 1 to WieOft Kontext "FindAndReplace" if NOT MatchCase.IsChecked then MatchCase.Check SearchFor.Settext Passage SearchNow.Click Kontext if NOT Active.Exists(2) then FindAndReplace.Cancel EditCopy if GetClipboardText <> Passage then warnlog "The search-request for '" & Passage & "' has been fault!" i = WieOft else if i = WieOft then hFindeImDokument = TRUE printlog "Searchphrase found " & i & " time(s)." end if end if else try Active.OK Kontext if Active.Exists then Active.OK warnlog "The search-request for '" & Passage & "' has been fault!" i = WieOft Kontext "FindAndReplace" if MatchCase.IsChecked then MatchCase.UnCheck FindAndReplace.Cancel catch Active.Yes Kontext if Active.Exists then Active.OK warnlog "The search-request for '" & Passage & "' has been fault!" i = WieOft Kontext "FindAndReplace" if MatchCase.IsChecked then MatchCase.UnCheck FindAndReplace.Cancel endcatch end if Next i Kontext "FindAndReplace" if FindAndReplace.Exists(2) then FindAndReplace.Cancel end if end function '------------------------------------------------------------------------- sub ErgebnisSchreiben ( Window, Name$ ) '/// ErgebnisSchreiben '///+ Used in context with making screenshots. Dim FileNum% : Dim i% Dim Datei$ Dim Text$ : Dim Text2$ Datei$ = sCapturePath + "Ergebis.txt" Text2$ = Window.Name Text$ = Text2$ + " => " + Name$ FileNum% = FreeFile Open Datei$ for Append as #FileNum% Print #FileNum%, Text$ Close #FileNum% end sub '------------------------------------------------------------------------- sub TextInDatei ( TextText$, Datei$ ) '/// TextInDatei Dim FileNum% FileNum% = FreeFile Open Datei$ for Append as #FileNum% Print #FileNum%, TextText$ Close #FileNum% end sub '------------------------------------------------------------------------- function hGetUIFiltername( vFiltername as string ) as string '/// Returns the in the UI used filter name. '///+ INPUT: 'internal', language independent filter name from FilterFactory. '///+ Examples:
  • hGetUIFiltername("StarOffice XML (Draw)") - Draw OOo 1.x/SO6.0/SO7 UI Filtername
    • '///+
  • sUIFiltername = hGetUIFiltername("StarOffice XML (Impress)") - Impress OOo 1.x/SO6.0/SO7 UI Filtername
'/// The 'internal' name can be found in the *.xcu in '///+ ..../share/registry/res/en-US/org/openoffice/TypeDetection/Filter.xcu. '/// See also: hGetFilternameExtension Dim i as integer Dim oOpenUNOService as object Dim oFilterName as object Dim oUno as object oUno = hGetUNOService(TRUE) oOpenUNOService = oUno.createInstance("com.sun.star.document.FilterFactory") try oFilterName = oOpenUNOService.getByName(vFiltername) for i=0 to ubound(oFilterName) if oFilterName(i).Name = "UIName" then hGetUIFiltername = oFilterName(i).Value end if next i catch warnlog "t_tools1.inc::hGetUIFiltername('" + vFiltername + "'): Filtername is not available." hGetUIFiltername = "" endcatch end function '------------------------------------------------------------------------- function hGetFilternameExtension ( vFilterName as string) '/// Returns the in the UI used filter name extension(s) as an array. '///+ Important: Also returns it as an array if there comes a string from the UNO API call. '/// Input: 'internal', language independent name '/// The 'internal' name can be found in the *.xcu in '///+ ../share/registry/modules/org/openoffice/TypeDetection/Types/fcfg_[Application_name]_types.xcu file(s). '/// List of some 'internal' filter names for OOo 2.0/SO8: '///+ '///+ '///+ '///+ '///+ '///+ '///+ '///+ '///+ '///+ '///+ '///+
Filterinternal nameNote
Spreadsheet (default)calc8-
Text document (default)writer8-
Master document (default)writerglobal8-
Drawing (default)draw8-
Presentation (default)impress8-
Formula/Math (default)math8-
HTMLwriter_web_HTMLtwo extensions!
Textwriter_text-
StarWriter 5.0writer_StarWriter_50-
StarCalc 5.0calc_StarCalc_50-

' (rewritten, compatible routine; July 2004) Dim i as integer Dim x as integer Dim oOpenUNOService as object Dim oFilterNameExtension as object Dim oUno as object dim a as integer Dim aExtensions() as string 'Initializize UNO comminication oUno = hGetUNOService(TRUE) 'Using the TypeDetection service oOpenUNOService = oUno.createInstance("com.sun.star.document.TypeDetection") 'Getting the Extension by given (internal; language- and product 'independent) filter name oFilterNameExtension = oOpenUNOService.getByName(vFiltername) 'using ubound to count the nodes for i=0 to ubound(oFilterNameExtension) 'if the node name is 'Extensions'... if oFilterNameExtension(i).Name = "Extensions" then '...if it's an array... if IsArray(oFilterNameExtension(i).Value) then 'create dimension of the integer a a = 10 're-dimension the array with the integer a Redim aExtensions(a) as string 'return the array into an array aExtensions() = oFilterNameExtension(i).Value() else '...otherwise 'build' an array with only 'one entry in (0) Redim aExtensions(0) as string aExtensions(0) = oFilterNameExtension(i).Value end if endif next i 'put the results into the return value of this function into an array. hGetFilternameExtension = aExtensions() end function '------------------------------------------------------------------------- function TrimTab ( sTrimmer as String ) as String '/// TrimTab '/// Input: the original text '/// Returns the string without <tab>s at the beginning and the end of a string. Dim sInterim as String sInterim = sTrimmer sInterim = lTrimTab ( sInterim ) TrimTab = rTrimTab ( sInterim ) end function '------------------------------------------------------------------------- function lTrimTab ( slTrimmer as String ) as String '/// lTrimTab '/// Input: the original text '/// Returns the string without <tab>s at the beginning. '/// Cuts <Tab's> at the beginning of a string ( left ) Dim i, iLen as Integer Dim sInterim as String iLen = len ( slTrimmer ) sInterim = slTrimmer for i=1 to iLen if Asc ( left ( sInterim, 1 ) ) = 9 then sInterim = Right ( sInterim, len ( sInterim ) - 1 ) else i=iLen+1 end if next i lTrimTab = sInterim end function '------------------------------------------------------------------------- function rTrimTab ( srTrimmer as String ) as String '/// rTrimTab '/// Input: the original text '/// Returns the string without <tab>s at the end. '/// Cuts <Tab's> at the beginning of a string ( right ) Dim i, iLen as Integer Dim sInterim as String iLen = len ( srTrimmer ) sInterim = srTrimmer for i=1 to iLen if Asc ( right ( sInterim, 1 ) ) = 9 then sInterim = left ( sInterim, len ( sInterim ) - 1 ) else i=iLen+1 end if next i rTrimTab = sInterim end function '------------------------------------------------------------------------- function TrimString (Content as String, delim as integer) as String ' Author: Frank Heitbrock (26.07.2002) '/// TrimString '/// Input: The String, the delimiter which should be cut from the string. '/// Returns the String without the delimiter. '/// Example: '///+ Content = " H a l l o ", delim = 32 (ascii for space character) '///+ Return = "Hallo" dim strlen as integer, i as integer, k as integer dim CharBuff(1 to 100) as String dim ResultStr as String ' at first cut the empty strings left and right of the String Content = lTrim(Content) Content = rTrim(Content) ' now we search for all appropriate ascii characters in the middle of the String and delete them strlen = len(Content) k = 1 for i = 1 to strlen if mid(Content, i, 1) <> chr(delim) then CharBuff(k) = mid(Content, i, 1) k = k +1 end if next i for i = 1 to k ResultStr = ResultStr + CharBuff(i) next i TrimString = ResultStr end function '------------------------------------------------------------------------- function ActiveDeactivateAsianSupport ( WhatState as Boolean ) as Boolean ' Author: Thorsten Ziehm '/// ActiveDeactivateAsianSupport '/// Input: TRUE or FALSE '///+ TRUE: The Asian support will be enabled. '///+ FALSE: The Asian support will be disabled. '/// Return: '///+ TRUE/FALSE for the last state of the checkbox in the office UI. ToolsOptions hToolsOptions ( "LanguageSettings", "Languages" ) IF Aktivieren.IsEnabled then 'the checkbox is disabled in asian versions ActiveDeactivateAsianSupport = Aktivieren.IsChecked ' the function gets the old state of the checkbox if WhatState = TRUE then try Aktivieren.Check catch endcatch else Aktivieren.UnCheck end if gAsianSup = WhatState ' Set the global variable Kontext "ExtrasOptionenDlg" ExtrasOptionenDlg.OK Sleep (3) else ActiveDeactivateAsianSupport = TRUE If WhatState = FALSE then warnlog "Deactivating of asian language support is not possible, because it is disabled in cjk versions" end if Kontext "ExtrasOptionenDlg" ExtrasOptionenDlg.OK Sleep (3) end if end function '------------------------------------------------------------------------- function ActiveDeactivateCTLSupport ( WhatState as Boolean ) as Boolean ' Author: Hercule Li (March 2004) '/// ActiveDeactivateCTLSupport '/// Input: TRUE or FALSE '/// TRUE : The CTL will be enabled. '/// FALSE: The CTL will be disabled. '/// Return: '/// TRUE/FALSE for the last state of the checkbox in the office UI. ToolsOptions hToolsOptions ( "LanguageSettings", "Languages" ) IF ComplexScriptEnabled.IsEnabled then 'the checkbox is disabled in CTL versions ActiveDeactivateCTLSupport = ComplexScriptEnabled.IsChecked ' the function gets the old state of the checkbox if WhatState = TRUE then ComplexScriptEnabled.Check else ComplexScriptEnabled.UnCheck end if gCTLSup = WhatState ' Set the global variable Kontext "ExtrasOptionenDlg" ExtrasOptionenDlg.OK Sleep (3) else ActiveDeactivateCTLSupport = TRUE If WhatState = FALSE then warnlog "Deactivating of CTL language support is not possible, because it is disabled in ctl versions" end if Kontext "ExtrasOptionenDlg" ExtrasOptionenDlg.OK Sleep (3) end if end function '------------------------------------------------------------------------- function GetDecimalSeperator ( optional sDummy$ ) as String '/// Precondition: Measuring unit has to be set to centimeter (cm) before using this function. (see: fSetMeasurementToCM()) '///+ Input: Number with fractionmark from NumericField as string '///+ Output: A dot (.) or a comma (,) as string Dim sCheckForSeparator as string Const cWhereIsThisFunction = "qa::qatesttool::global::tools::inc::t_tools1.inc::GetDecimalSeperator: " Dim bDotOrCommaIncluded as boolean 'Setting the determination of a dot or a comma to FALSE until it was successfull. bDotOrCommaIncluded = FALSE if IsMissing(sDummy$) then '/// Opening a new document depending on gApplication value and closing it at the end. Call hNewDocument '/// Tools / Options / (Modul: gApplication) / General tabpage. ToolsOptions '///+
  1. Reading the string of the tabulator numeric field
    2. select case UCase(gApplication) case "WRITER", "TEXTDOKUMENT" : Call hToolsOptions("TEXTDOCUMENT","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "CALC", "TABELLENDOKUMENT" : Call hToolsOptions("SPREADSHEET","GENERAL") sCheckForSeparator = Tabulator.GetText case "IMPRESS", "PRAESENTATION" : Call hToolsOptions("PRESENTATION","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "DRAW", "ZEICHNUNG" : Call hToolsOptions("DRAWING","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "GLOBALDOC", "GLOBALDOKUMENT": Call hToolsOptions("TEXTDOCUMENT","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "HTML", "HTMLDOKUMENT" : Call hToolsOptions("TEXTDOCUMENT","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case else : warnlog cWhereIsThisFunction & "For this module ("& gApplication &") no decimal seperator setting exists." end select Kontext "ExtrasOptionenDlg" ExtrasOptionenDlg.OK if Instr(sCheckForSeparator, ",") > 0 then GetDecimalSeperator = "," bDotOrCommaIncluded = TRUE endif if Instr(sCheckForSeparator, ".") > 0 then GetDecimalSeperator = "." bDotOrCommaIncluded = TRUE endif Call hCloseDocument else '///+
  2. or determining the seperator depending on the OPTIONAL value (string).
'Get position of fraction mark / get IT if InStr (sDummy$, ",") > 0 then GetDecimalSeperator = "," bDotOrCommaIncluded = TRUE endif if InStr (sDummy$, ".") > 0 then GetDecimalSeperator = "." bDotOrCommaIncluded = TRUE endif endif '/// If the determination failed the dot will be used (default) as decimal seperator. if bDotOrCommaIncluded = FALSE then warnlog cWhereIsThisFunction & "Unable to determine decimal separator. Setting dot (.) as default." GetDecimalSeperator = "." endif printlog "Info: Decimal Seperator is a '" & GetDecimalSeperator & "'." end function sub sResetTheOffice as boolean Dim uno Dim ap Dim xViewRoot Dim apara(1) As new com.sun.star.beans.PropertyValue Dim temp() Dim i,x as integer Dim sString as string Dim fDeleteList(32000) as string Dim sLanguage as string Dim bError as boolean Dim sDefaultLocale as string Dim sDefaultLocaleCJK as string Dim sDefaultLocaleCTL as string Dim sfgetL10Nvalue as string Dim SetupXML as String Dim SetupXMLNet as string Dim SetupXMLDefault as string Dim sLanOutIni as string sString = "qa:qatesttool:calc:options:inc:coption1.inc:: " sResetTheOffice = TRUE ' only run on UNIX platforms; there is a problem with the quickstarter on win32 if ("unx" = gPlatgroup) then try SetupXML = gOfficePath & ConvertPath("user\registry\data\org\openoffice\Setup.xcu") ' function 'fgetL10Nvalue' is also in this library sLanOutIni = fgetL10Nvalue(SetupXML) catch try ' BugID 98315 -> looking in networkpath for the language until bug will be fixed. SetupXMLNet = gNetzOfficePath & ConvertPath("share\registry\data\org\openoffice\Setup.xcu") sLanOutIni = fgetL10Nvalue(SetupXMLNet) catch try ' It is an English FAT version 645m9s2 or higher. SetupXMLDefault = gOfficePath & ConvertPath("share\registry\data\org\openoffice\Setup.xcu") sLanOutIni = fgetL10Nvalue(SetupXMLDefault) catch warnlog sString & SetupXML & " not found => can't get the correct Office-Language!." sResetTheOffice = FALSE Exit sub endcatch endcatch endcatch uno=hGetUnoService() 'Get UI language try ap=uno.createInstance("com.sun.star.configuration.ConfigurationProvider") apara(0).Name="nodepath" apara(0).Value="/org.openoffice.Office.Linguistic/General" apara(1).Name="lazywrite" apara(1).Value=False xViewRoot=ap.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess",aPara()) sLanguage = sfgetL10Nvalue sDefaultLocale = xViewRoot.getPropertyValue("DefaultLocale") sDefaultLocaleCJK = xViewRoot.getPropertyValue("DefaultLocale_CJK") sDefaultLocaleCTL = xViewRoot.getPropertyValue("DefaultLocale_CTL") printlog "Old UI language: '" + sLanOutIni + "'" printlog "Old default locale: '" + sDefaultLocale + "'" printlog "Old default locale CJK: '" + sDefaultLocaleCJK + "'" printlog "Old default locale CTL: '" + sDefaultLocaleCTL + "'" xViewRoot.dispose() bError = FALSE catch warnlog sString + "Failed to read UI language." bError = TRUE endcatch if NOT bError then 'Close OOo try ' To prevent restarting of OOo, the try/catch is around this and ' to prevent messages about communication errors printlog ResetApplication FileExit "SynchronMode", TRUE try ' It is no error, if this fails - so it gets its own try/catch kontext if active.exists(5) then active.no 'discard changes endif catch endcatch bError = FALSE catch warnlog sString + "Failed to close OOo." bError = TRUE endcatch sleep 10 'To wait until OOo is realy away endif 'only act, if no error and if language <> '' if (NOT bError AND sLanguage <> "") then 'Remove user directory try if (right(gOfficePath,1)=gPathSigne) then 'Dir doesn't work, is a path singe is at the end gOfficePath = left(gOfficePath,len(gOfficePath)-1) endif printlog "Going to delete directory: '" + gOfficePath + "'" if (dir(gOfficePath) = "") then qaErrorlog "Directory is already deleted." else rmDir (gOfficePath) if (dir(gOfficePath) <> "") then warnlog "Directory wasn't deleted." endif endif bError = FALSE catch warnlog sString + "Failed to delete user directory." bError = TRUE endcatch endif 'Start OOo and restore language 'Needs only to be done, if UI language wasn't the default (!= "") if ((sLanguage & sDefaultLocale & sDefaultLocaleCJK & sDefaultLocaleCTL) <> "") then try hStartTheOffice Call hDisableQuickstarter 'Here we need the Exit from a running Quickstarter... Call ExitRestartTheOffice uno=hGetUnoService() ap=uno.createInstance("com.sun.star.configuration.ConfigurationProvider") apara(0).Name="nodepath" apara(0).Value="/org.openoffice.Office.Linguistic/General" apara(1).Name="lazywrite" apara(1).Value=False xViewRoot=ap.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess",aPara()) if (sLanOutIni <> "") then printlog "Old UI language: '" + sLanOutIni + "'" xViewRoot.setPropertyValue("UILocale", sLanOutIni) xViewRoot.commitChanges() endif if (sDefaultLocale <> "") then printlog "Old default locale: '" + sDefaultLocale + "'" xViewRoot.setPropertyValue("DefaultLocale", sDefaultLocale) xViewRoot.commitChanges() endif if (sDefaultLocaleCJK <> "") then printlog "Old default locale CJK: '" + sDefaultLocaleCJK + "'" xViewRoot.setPropertyValue("DefaultLocale_CJK", sDefaultLocaleCJK) xViewRoot.commitChanges() endif if (sDefaultLocaleCTL <> "") then printlog "Old default locale CTL: '" + sDefaultLocaleCTL + "'" xViewRoot.setPropertyValue("DefaultLocale_CTL", sDefaultLocaleCTL) xViewRoot.commitChanges() endif if xViewRoot.hasPendingChanges() then warnlog(sFileFunction+"Changes still pending...") endif xViewRoot.dispose() catch warnlog sString + "Failed to set UI language." exit sub endcatch endif Call ExitRestartTheOffice endif end sub '------------------------------------------------------------------------- sub raiseApplication ' Try to solve focus problem on MacOS X; After calling this function, OOo should be most front; Dim i as integer Dim a as integer Dim b as integer Dim tBundle as string Dim aPath ' Calling just the .app with open on MacOS X via shell command if gPlatform = lcase("osx") then aPath = split(gNetzOfficePath, gPathSigne) a=0 ' make sure 'Contents' is just one time in path for i=0 to uBound(aPath) if "Contents" = aPath(i) then a=a+1 endif next i ' exit if not if a<>1 then exit sub end if i=inStr(gNetzOfficePath, "Contents") tBundle=left(gNetzOfficePath, i-2) shell("open",1 ,tBundle, true) end if end sub