Aufmaßfunktion

[umsteiger]

Hallo,
gibt es in OO Calc eine Art "Aufmaßfunktion"?
Beispiel:
Zelle A1 <5*8>; automatische Ausgabe des Wertes in Zelle B1 <40>
Gruss umsteiger

[MB29]

Kannst Du mir bitte erklären warum Du "5 mal 8" in eine Zelle und nicht in zwei Zellen schreiben willst (A1=5; B1=8; C1=A1*B1)?

[umsteiger]

Hallo MB29,
das Beispiel war vielleicht zu mißverständlich.
Die Funktion ist für mich sehr hilfreich bei der Eingabe und Auswertung von Flächen und Massen.
Der Lösungsansatz mit den verschiedenen Zellen und anschließender Verknüpfung ist sicherlich üblicher.
Ich benutze derzeit noch Excel, möchte aber auf OpenOffice umsteigen.
Gibt es eine Entsprechung für die Excel-Funktion:
=AUSWERTEN(INDIREKT("A1"))
Beim Öffnen der Exceldatei in Calc wurde diese Funktion leider nicht konvertiert.
Gruss umsteiger

[Karolus]

Hallo

Jein, das gibts nur über eine Makrofunktion, schau dir's mal an :http://www.ooo-portal.de/index.php?modu ... Auswertung

Die Syntax dazu wäre dann :
=AUSWERTUNG(A1)

Gruß Karo

[umsteiger]

Hallo Karo,
die Makrofunktion hat auf Anhieb geklappt, vielen Dank.
Ich habe dazu aber noch eine Frage:
Gibt es eine Möglichkeit, die berechneten Werte automatisch zu aktualisieren?
Gruss umsteiger

[Karolus]

Hallo

Suchst du nach ->Extras->Zellinhalte->? Automatisch berechnen ?

Gruß Karo

[umsteiger]

Hallo Karo,
die von Dir genannte Aktualisierungsoption funktioniert leider nicht...
Gibt es vielleicht die Möglichkeit, das Makro auch bei Mehrfachmarkierung auszuführen?
Gruss umsteiger

[Karolus]

Hallo

Jetzt muss ich erstmal zurückfragen :
Hast du die Funktion über ->Extras ->Makros-- ausgeführt ?, oder über eine Eintrag in eine Zelle zb. in B1:
=AUSWERTUNG(A1) ?
Im letztem Fall kannst du doch die Formel in B1 nach unten "ziehen" und der Bezug passt sich entsprechend auf A2 , A3 usw. an.



Ich hab gerade nochmal in den von mir gelinkten Thread hineingeschaut, welche Lösungvariante benutzt du jetzt eigentlich, die Funktion AUSWERTUNG in Verbindung mit Evaluate oder das spätere (aufgezeichnete) Makro, das den Inhalt einer Zelle in die rechte Nachbarzelle kopiert und dort ein = zeichen voranstellt ?

Gruß Karo

[umsteiger]

Hallo Karo,
die Funktion habe ich über ->Extras ->Makros-- ausgeführt.
(Hat prima geklappt)
Daher auch meine Frage zur Aktualisierung.

Ich habe nun versucht, die Möglichkeit mit =AUSWERTUNG(A1) in meine Datei einzufügen.
Dazu habe ich den Quelltext

function Auswertung(formel as string)
f = Evaluate(formel,0,e)
Auswertung = (f)
end function

Option Explicit 'always use this option in vb
usw...

in das Basic-Fenster eingefügt.

Leider kam dann die Fehlermeldung (s.Bild)
[img]http://d:\fehler01.jpg[/img]

Woran könnte das liegen?

Gruss
umsteiger

[umsteiger]

Hallo Karo,
mit Bild is wohl nix
Fehlermeldung:
BASIC-Laufzeitfehler, Variable nicht definiert.
In Zeile:
f = Evaluate(formel,0,e)

Gruss umsteiger

[Karolus]

Hallo Umsteiger

Füg mal vor der angemeckerten Zeile :
DIM f as single
ein, und kopier diese ersten 5 Zeilen nach unterhalb der Zeile:
"Private Const evElse = 16"

Funktioniert es jetzt ?

Gruß Karo

[umsteiger]

Hallo Karo,
leider ist immer noch der Wurm drin, Fehlermeldung:
"BASIC-Laufzeitfehler, Variable nicht definiert"
in Zeile: f = Evaluate(formel0,,e)

Hier mal der erste Teil des Codes:

Option Explicit 'always use this option in vb
Private Const Pi As Double = 3.14159265358979
Private Const e As Double = 2.71828182845905
Private argX As String
Private Const evNumber = 1
Private Const evConstant = 2
Private Const evFunction = 5
Private Const evLeftBracket = 6
Private Const evRightBracket = 7
Private Const evOperand = 8
Private Const evElse = 16

function Auswertung(formel) as string
Dim f as single
f = Evaluate(formel0,,e)
Auswertung = (f)
end function

Gruss, umsteiger

[Karolus]

Hallo Umsteiger

f = Evaluate(formel0,,e)

da hat sich ein Fehler ^^^ eingeschlichen, korrigier mal nach :
....(formel,0,e)

Gruß Karo

[umsteiger]

Hallo Karo,
leider hat die Korrektur nichts genützt, die Fehlermeldung ist recht hartnäckig: BASIC-Laufzeitfehler. Argument ist nicht optional.
Zeile: f = Evaluate(formel,0,e)

Kannst Du mal den folgenden Quelltext mit Deiner funktionierenden Lösung abgleichen? Ich habe das Folgende eins zu eins kopiert.
Übrigens noch einen schönen Abend,
Gruss umsteiger

#################################
Option Explicit 'always use this option in vb
Private Const Pi As Double = 3.14159265358979
Private Const e As Double = 2.71828182845905
Private argX As String
Private Const evNumber = 1
Private Const evConstant = 2
Private Const evFunction = 5
Private Const evLeftBracket = 6
Private Const evRightBracket = 7
Private Const evOperand = 8
Private Const evElse = 16

function Auswertung(formel as string)
Dim f as single
f = Evaluate(formel,0,e)
Auswertung = (f)
end function

Public Function Error_Message(n As Integer) As String
Select Case n
Case 0
Error_Message = "No error !"
Case 1
Error_Message = "Error evaluating power function."
Case 2
Error_Message = "Error evaluating logarithm. The argument must be > 0."
Case 3
Error_Message = "Error evaluating tangent."
Case 4
Error_Message = "Error evaluating square root. The argument must be >= 0."
Case 5
Error_Message = "Error evaluating arcsine. The argument must be in [-1, 1]."
Case 6
Error_Message = "Error evaluating arccosine. The argument must be in [-1, 1]."
Case 7
Error_Message = "Division by zero."
Case 11
Error_Message = "Unexpected end of parenthesis."
Case 12
Error_Message = "Operators must be followed by number, constant, function."
Case 13
Error_Message = "Function must be followed by parenthesis."
Case 14
Error_Message = "An error occured in evaluation"
Case 15
Error_Message = "Expression expected."
Case 16
Error_Message = "Unknown function."
Case 17
Error_Message = "Enter the value for which you want to evaluate the function."
Case 18
Error_Message = "An error occured in evaluation"
End Select
End Function

Private Function IsNum(ByVal s As String) As Boolean
IsNum = IsNumeric(s) Or (s = ".") Or (s = ",")
End Function

Private Function Lexical_Unit(ByVal c As String) As Integer
c = LCase$(c)
If IsNum(c) Then
Lexical_Unit = evNumber
Else
Select Case c
Case argX, "e", "pi"
Lexical_Unit = evConstant
Case "ln", "abs", "exp", "sqrt", "int", "frac", _
"sin", "cos", "tan", "asin", "acos", "atan", _
"sinh", "cosh", "tanh"
Lexical_Unit = evFunction
Case "("
Lexical_Unit = evLeftBracket
Case ")"
Lexical_Unit = evRightBracket
Case "+", "-", "*", "/", "^", "@"
Lexical_Unit = evOperand
Case Else
Lexical_Unit = evElse
End Select
End If
End Function

Public Sub Next_Token(ByVal S As String, ByVal k As Integer, _
ByRef i1 As Integer, ByRef i2 As Integer)
Dim s1 As String, s2 As String
Dim other_token As Boolean
Do While Mid$(S, k, 1) = " "
k = k + 1
Loop
i1 = k
s1 = LCase$(Mid$(S, k, 1))
Do
s2 = LCase$(Mid$(S, k + 1, 1))
other_token = (s1 <> s2) And Not (IsNum(s1) And IsNum(s2)) And _
Not ((s1 >= "a") And (s1 <= "z") And (s2 >= "a") And (s2 <= "z"))
k = k + 1
s1 = s2
Loop Until other_token Or ((s1 = "(") And (s2 = "(")) Or ((s1 = ")") And (s2 = ")"))
i2 = k - 1
End Sub

Public Sub Check_Syntax(ByVal S As String, ByVal WithX As Boolean, _
ByRef Function_Error As Integer, ByRef i1 As Integer)
Dim one As Integer, two As Integer, brackets As Integer
Dim k As Integer, i2 As Integer, Si As String, Sk As String
i1 = 2
i2 = 1
argX = IIf(WithX, "x", "")
Function_Error = IIf(Trim(S) = "", 17, 0)
If Function_Error = 17 Then Exit Sub
S = "(" + S + ")"
Si = "("
k = i2 + 1
one = 6 ' Lexical_Unit ("(")
brackets = 1
Do While k <= Len(S)
Next_Token S, k, i1, i2
Sk = Mid$(S, i1, i2 - i1 + 1)
k = i2 + 1
two = Lexical_Unit(Sk)
If two = 16 Then
Function_Error = 16
Exit Sub
End If
Select Case Sk
Case "(": brackets = brackets + 1
Case ")": brackets = brackets - 1
End Select
If brackets < 0 Then
Function_Error = 11
Exit Sub
End If
Select Case one
Case evNumber
If Not ((two = evConstant) Or (two = evLeftBracket) Or _
(two = evRightBracket) Or (two = evOperand)) Then Function_Error = 12
Case evConstant
If Not ((two = evLeftBracket) Or (two = evRightBracket) Or (two = evOperand)) Then Function_Error = 12
Case evFunction
If (two <> evLeftBracket) Then Function_Error = 13
Case evLeftBracket
If (two = evRightBracket) Or ((two = evOperand) And (Sk <> "-")) Then Function_Error = 14
Case evRightBracket
If (two <> evOperand) And (two <> evRightBracket) Then Function_Error = 15
Case evOperand
If (two = evRightBracket) Or (two = evOperand) Then Function_Error = 14
Case evElse
Function_Error = 16
End Select
If Function_Error > 0 Then Exit Sub
Si = Sk
one = two
Loop
If brackets <> 0 Then Function_Error = 11
End Sub

Private Function Priority(ByVal c As String) As Integer
Dim P As Integer
c = Left$(c, 1)
Select Case c
Case "(", ")": P = 0 'Priority 0 : brackets
Case "+", "-": P = 1 'Priority 1 : aditive operators
Case "*", "/": P = 2 'Priority 2 : multiplicative operators
Case "^", "@": P = 3 'Priority 3 : exponential operators (a @ b -> log(a), base=b)
Case "a" To "z", "A" To "Z": P = 4 'Priority 4 : math functions, constants
End Select
Priority = P
End Function

Public Function Evaluate(ByVal S As String, ByVal x As Double, _
ByRef Function_Error As Integer) As Double
' parse expression and evaluate function
On Error GoTo Overflow
Dim opd(200) As Double, op(200) As String
Dim top1 As Integer, top2 As Integer, i As Integer, k As Integer
Dim value As Double, x1 As Double, x2 As Double
Dim i1 As Integer, i2 As Integer, Si As String, Sk As String, S0 As String
Function_Error = 0
argX = "x"
top1 = 0
top2 = 1
op(top2) = "("
S = S + ")"
i = 1
Si = "("
Do While (i <= Len(S)) And (top2 > 0)
Next_Token S, i, i1, i2
Sk = Si
Si = Mid$(S, i1, i2 - i1 + 1)
i = i2 + 1
If IsNum(Si) Then
top1 = top1 + 1
opd(top1) = Val(Replace$(Si, ",", "."))
value = opd(top1)
Else
Select Case LCase$(Si)
Case "(": top2 = top2 + 1: op(top2) = "("
Case argX, "pi", "e":
top1 = top1 + 1
S0 = LCase$(Si)
Select Case S0
Case argX: opd(top1) = x
Case "pi": opd(top1) = Pi
Case "e": opd(top1) = e
End Select
If IsNum(Sk) Then
top2 = top2 + 1
op(top2) = "*"
End If
Case Else
Do While (top2 > 0) And (op(top2) <> "(") And (op(top2) <> ")") _
And (Priority(op(top2)) >= Priority(Si))
If top1 >= 2 Then x1 = opd(top1 - 1)
x2 = opd(top1)
Select Case LCase$(op(top2))
Case "+": value = x1 + x2
Case "-": value = x1 - x2
Case "~": value = -x2 'unary minus
Case "*": value = x1 * x2
Case "/":
If x2 <> 0 Then
value = x1 / x2
Else: Function_Error = 7: Evaluate = 0: Exit Function
End If
Case "^":
If ((x1 < 0) And (x2 <> Int(x2)) Or _
((x1 = 0) And (x2 = 0))) Then
Function_Error = 1: Evaluate = 0: Exit Function
Else: value = x1 ^ x2
End If
Case "@": 'logarithm
If (x1 > 0) And (x2 > 0) And (x2 <> 1) Then
value = Log(x1) / Log(x2)
Else
If x2 = 1 Then
value = Log(x1)
Else: Function_Error = 2: Evaluate = 0: Exit Function
End If
End If
Case "sin": value = Sin(x2)
Case "cos": value = Cos(x2)
Case "tan":
If Cos(x2) <> 0 Then
value = Tan(x2)
Else: Function_Error = 3: Evaluate = 0: Exit Function
End If
Case "asin":
If (x2 > -1) And (x2 < 1) Then
value = Atn(x2 / Sqr(1 - x2 * x2))
ElseIf x2 = -1 Then
value = -Pi / 2
ElseIf x2 = 1 Then
value = Pi / 2
Else: Function_Error = 5: Evaluate = 0: Exit Function
End If
Case "acos":
If (x2 > 0) And (x2 <= 1) Then
value = Atn(Sqr(1 - x2 * x2) / x2)
ElseIf (x2 < 0) And (x2 >= -1) Then
value = Atn(Sqr(1 - x2 * x2) / x2) + Pi
ElseIf x2 = 0 Then
value = Pi / 2
Else: Function_Error = 6: Evaluate = 0: Exit Function
End If
Case "atan": value = Atn(x2)
Case "sinh": value = (Exp(x2) - Exp(-x2)) * 0.5
Case "cosh": value = (Exp(x2) + Exp(-x2)) * 0.5
Case "tanh": value = (Exp(x2) - Exp(-x2)) / (Exp(x2) + Exp(-x2))
Case "ln":
If x2 > 0 Then
value = Log(x2)
Else: Function_Error = 2: Evaluate = 0: Exit Function
End If
Case "exp": value = Exp(x2)
Case "abs": value = Abs(x2)
Case "sqrt":
If x2 >= 0 Then
value = Sqr(x2)
Else: Function_Error = 4: Evaluate = 0: Exit Function
End If
Case "int": value = Int(x2)
Case "frac": value = x2 - Int(x2)
End Select
If ((LCase$(Mid$(op(top2), 1, 1)) < "a") Or _
(LCase$(Mid$(op(top2), 1, 1)) > argX)) _
And (op(top2) <> "~") Then top1 = top1 - 1
opd(top1) = value
top2 = top2 - 1
Loop
If top2 > 0 Then
If (op(top2) <> "(") Or (Si <> ")") Then
top2 = top2 + 1
op(top2) = IIf((Sk = "(") And (Si = "-"), "~", Si)
Else
top2 = top2 - 1
End If
End If
End Select
End If
Loop
Evaluate = opd(1)
Exit Function
Overflow:
Function_Error = 18 'overflow
MsgBox "overflow"
End Function

Public Function Derive (ByVal S As String, ByVal x As Double, _
ByRef Function_Error As Integer) As Double
' ================================================================
' f(x-2h)-8f(x-h)+8f(x+h)-f(x+2h)
' f'(x) = ------------------------------- (derivative formula)
' 12 h
' =================================================================
Dim v1 As Double, v2 As Double, v3 As Double, v4 As Double
Dim FErr As Integer
Const h as Double = 0.000456
Derive = 0
Function_Error = 1
v1 = Evaluate(S, x - 2 * h, FErr)
If FErr <> 0 Then Exit Function
v2 = Evaluate(S, x - h, FErr)
If FErr <> 0 Then Exit Function
v3 = Evaluate(S, x + h, FErr)
If FErr <> 0 Then Exit Function
v4 = Evaluate(S, x + 2 * h, FErr)
If FErr <> 0 Then Exit Function
Function_Error = 0
Derive = (v1 - 8 * v2 + 8 * v3 - v4) / (12 * h)
End Function

Function Find_root_Newton(ByVal S As String, ByVal x0 As Double, _
ByVal eps As Double, FErr As Integer) As Double
' solve equations using Newton method
On Error Resume Next
Dim x1 As Double, v1 As Double, v2 As Double
Dim FErr1 As Integer, FErr2 As Integer
Dim steps As Integer
FErr = 0
x1 = x0
steps = 0
Do
x0 = x1
v1 = Evaluate(S, x0, FErr1)
v2 = Derive(S, x0, FErr2)
If (FErr1 * FErr2 > 0) Or (v2 = 0) Then
Find_root_Newton = 0
FErr = 1
Exit Function
Else
x1 = x0 - v1 / v2
End If
steps = steps + 1
Loop Until (Abs(x1 - x0) < eps) Or (steps = 100)
If Evaluate(S, x1, FErr1) < eps Then
Find_root_Newton = x1
Else
Find_root_Newton = 0
FErr = 2
End If
End Function

Function Find_root_bisection(ByVal S As String, ByVal a As Double, _
ByVal b As Double, ByVal eps As Double, _
ByRef Err As Integer) As Double
' solve equations using bisection method
On Error Resume Next
Dim ya As Double, yc As Double, c As Double
Dim steps As Integer, FErr As Integer
Err = 0
Do
c = (a + b) / 2
ya = Evaluate(S, a, FErr)
yc = Evaluate(S, c, FErr)
If ya = 0 Then
Find_root_bisection = a
Exit Function
ElseIf yc = 0 Then
Find_root_bisection = c
Exit Function
End If
If ya * yc < 0 Then
b = c
Else
a = c
End If
Loop Until (Abs(b - a) < eps)
Find_root_bisection = c
End Function
###############################

[Karolus]

Hallo Umsteiger

Ich hab jetzt mal bei mir alle Module leergeräumt die in irgendeiner Weise mit AUSWERTUNG zu tun haben, und dann deinen Quelltext in ein Modul hineinkopiert.-
Bei mir funktionierts auch damit , mit OOoversion 2.02.

Gestern hatte ich mit OOo 1.14 und 1.13 getestet beide Male ohne Erfolg mit der Fehlermeldung 'Overflow'

Mit welcher OOo version arbeitest du ?

Gruß Karo