'encoding UTF-8 Do not remove or change this line! '************************************************************** ' ' Licensed to the Apache Software Foundation (ASF) under one ' or more contributor license agreements. See the NOTICE file ' distributed with this work for additional information ' regarding copyright ownership. The ASF licenses this file ' to you under the Apache License, Version 2.0 (the ' "License"); you may not use this file except in compliance ' with the License. You may obtain a copy of the License at ' ' http://www.apache.org/licenses/LICENSE-2.0 ' ' Unless required by applicable law or agreed to in writing, ' software distributed under the License is distributed on an ' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY ' KIND, either express or implied. See the License for the ' specific language governing permissions and limitations ' under the License. ' '************************************************************** '* '* short description : Tools (1) '* '\****************************************************************************** private SLEEP_TIME_REQUESTED as integer private SLEEP_CALLS_SUM as integer private SLEEP_TIME_USED as integer 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 ' catch if had any effects if Window.GetText = Selektion then window.MouseDoubleClick 5, i +1 ' if optional parameter provided if (isMissing (bFocus) = FALSE) then 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 endif 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 ' mysql format for status.inc if Zeitspanneh < 10 then 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 '******************************************************************************* function Sleep( optional _iSeconds as integer ) as integer const CFN = "global::tools::includes::required::Sleep(...): " const STATUS_NO_DELAY = 0 const STATUS_TIMEOUT_EXCEEDED = 1 const STATUS_WAITSLOT_CRASHED = 2 const STATUS_CLASSIC_WAIT_USED = 3 ' This is the "classic" behavior of the sleep function. If you did not set ' GLOBAL_USE_NEW_SLEEP to TRUE in your .bas file, this will be used. if ( not GLOBAL_USE_NEW_SLEEP ) then if ( IsMissing( _iSeconds ) ) then wait( 1000 ) else wait( _iSeconds * 1000 ) endif sleep() = STATUS_CLASSIC_WAIT_USED exit function endif ' This is an extended and accelerated version of the "classic" sleep() ' subroutine which used to call Wait( n ) with a given number of ' milliseconds. This function uses WaitSlot( n ) and is dynamic. ' The try...catch block is necessary because WaitSlot() can - under certain ' yet unknown conditions - make the office application crash. ' When called with 0 seconds we return 0 (dynamic sleep statements within ' test initialization can actually call the function with a Zero parameter) ' A negative number forces the function to use the classic behavior. ' If no time is given the function defaults to 5 seconds. ' The function now provides returnvalues: ' 0 = Normal WaitSlot() used, this is the preferred method. ' 1 = WaitSlot() timeout reached, one extra second was added. ' This is bad and the script developer should try to fix it. ' 2 = Wait() was used (classic method, fallback). ' 3 = Wait() was used (forced old behavior) dim iMilliseconds as integer dim iStatus as integer : iStatus = 0 dim lBegin as long : lBegin = GetSystemTicks dim iSeconds as integer : iSeconds = 5 dim iSystemDelay as integer : iSystemDelay = 1000 dim iTimeDiff as long : iTimeDiff = 0 ' On Solaris we are a little slower, so we increase the system delay a little if ( instr( lcase( gtSysName ) , "solaris" ) > 0 ) then iSystemDelay = 1500 endif ' Override default wait time (5 seconds) if parameter is given if ( not IsMissing( _iSeconds ) ) then iSeconds = _iSeconds endif ' Do exit directly if no wait requested if ( iSeconds = 0 ) then Sleep() = STATUS_NO_DELAY exit function endif ' We need the time in ms and absolute (parameter can be negative) iMilliseconds = abs( iSeconds * 1000 ) ' Here we actually do the delay and generate return values ' If WaitSlot() times out, we give an extra second (wait(1000)) if ( iSeconds > 0 ) then try if ( WaitSlot( iMilliseconds ) <> WSFinished ) then wait( iSystemDelay ) iStatus = STATUS_TIMEOUT_EXCEEDED endif catch wait( iMilliseconds ) iStatus = STATUS_WAITSLOT_CRASHED endcatch else Wait( iMilliseconds ) iStatus = STATUS_CLASSIC_WAIT_USED endif ' Find out how long it took, warn if time was zero (sleep most likely not required) iTimeDiff = GetSystemTicks - lBegin if ( iTimeDiff = 0 ) then printlog( CFN & "Zero time. Please consider removing Sleep() statement" ) endif if ( GVERBOSE ) then SLEEP_CALLS_SUM = SLEEP_CALLS_SUM + 1 SLEEP_TIME_USED = SLEEP_TIME_USED + iTimeDiff / 1000 ' good enough SLEEP_TIME_REQUESTED = SLEEP_TIME_REQUESTED + iSeconds printlog( CFN & "--------------------- New call ---------------------" ) printlog( CFN & "Total Sleep()-Time requested (seconds): " & SLEEP_TIME_REQUESTED ) printlog( CFN & "Total Sleep()-Time used (seconds).....: " & SLEEP_TIME_USED ) printlog( CFN & "Total number of Sleep()-Calls.........: " & SLEEP_CALLS_SUM ) endif ' Try to make something useful out of the status if ( iStatus <> 0 ) then printlog( CFN & "Sleep(" & abs( iSeconds ) & "), took " _ & iTimeDiff & " ms, rc=" & iStatus ) select case iStatus case STATUS_TIMEOUT_EXCEEDED : printlog( CFN & "Timeout exceeded." ) case STATUS_WAITSLOT_CRASHED : printlog( CFN & "Used Wait(n). WaitSlot() failed." ) case STATUS_CLASSIC_WAIT_USED : printlog( CFN & "Used Wait(n). Classic behavior forced" ) end select endif Sleep() = iStatus end function '******************************************************************************* 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 endif 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 ( not FileExists(sPicName) ) then mkdir sPicName 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 '******************************************************************************* 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 "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 endif if Active.Exists then Active.OK endif 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 "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 endif 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 endif warnlog "The search-request for '" & Passage & "' has been fault!" i = WieOft Kontext "FindAndReplace" if MatchCase.IsChecked then MatchCase.UnCheck endif FindAndReplace.Cancel catch Active.Yes Kontext if Active.Exists then Active.OK endif warnlog "The search-request for '" & Passage & "' has been fault!" i = WieOft Kontext "FindAndReplace" if MatchCase.IsChecked then MatchCase.UnCheck endif FindAndReplace.Cancel endcatch end if Next i Kontext "FindAndReplace" if FindAndReplace.Exists(2) then FindAndReplace.Cancel end if end function '******************************************************************************* sub TextInDatei ( TextText$, Datei$ ) '/// TextInDatei Dim FileNum% FileNum% = FreeFile Open Datei$ for Append as #FileNum% Print #FileNum%, TextText$ Close #FileNum% end sub '******************************************************************************* 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" hCloseDialog( ExtrasOptionenDlg, "ok" ) 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" hCloseDialog( ExtrasOptionenDlg, "ok" ) 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" hCloseDialog( ExtrasOptionenDlg, "ok" ) 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" hCloseDialog( ExtrasOptionenDlg, "ok" ) 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 gApplication case "WRITER" Call hToolsOptions("WRITER","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "CALC" Call hToolsOptions("CALC","GENERAL") sCheckForSeparator = Tabulator.GetText case "IMPRESS" Call hToolsOptions("IMPRESS","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "DRAW" Call hToolsOptions("DRAW","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "MASTERDOCUMENT" Call hToolsOptions("WRITER","GENERAL") sCheckForSeparator = Tabulatorenabstand.GetText case "HTML" Call hToolsOptions("WRITER","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 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 sLanOutIni = fgetL10Nvalue() catch warnlog sString & "can't get the correct Office-Language!." sResetTheOffice = FALSE Exit sub 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 iCurrentDir as integer dim iNumberOfHits as integer : iNumberOfHits = 0 dim iDirPosition as integer dim tBundle as string dim aPath ' string array with dynamic itemcount, intended. ' Calling just the .app with open on MacOS X via shell command if ( lcase( gPlatform ) = "osx" ) then ' Split the path into its components aPath = split(gNetzOfficePath, gPathSigne) ' make sure 'Contents' is just one time in path for iCurrentDir = 0 to uBound(aPath) if "Contents" = aPath( iCurrentDir ) then iNumberOfHits = iNumberOfHits + 1 next iCurrentDir ' exit if not if ( iNumberOfHits <> 1 ) then exit sub iDirPosition = inStr( gNetzOfficePath, "Contents" ) tBundle = left( gNetzOfficePath, iDirPosition - 2 ) shell( "open", 1, tBundle, true ) end if end sub