'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
'///+ - Reading the string of the tabulator numeric field
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
'///+ - 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