Option Explicit Sub Main() MsgBox "Result = " & EvaluateExpression("[#10133 - #10132] / 2.") End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' G-code expression evaluator for the Mach3 ' ' SOURCE: "Read-To-Run" Visual Basic Algorithms by ... ' (modified by Sittinduck for the G-codes ) ' ' Public Function EvaluateExpression(ByVal Expression As String) As Double Const PREC_NONE As Integer = 11 Const PREC_UNARY As Integer = 10 ' Not actually used. Const PREC_POWER As Integer = 9 Const PREC_TIMES As Integer = 8 Const PREC_DIV As Integer = 7 Const PREC_PLUS As Integer = 6 Dim expr As String Dim is_unary As Boolean Dim next_unary As Boolean Dim parens As Integer Dim pos As Long Dim expr_len As Long Dim ch As String Dim ch2 As String Dim opr As String Dim lexpr As String Dim rexpr As String Dim status As Long Dim best_pos As Long Dim best_len As Integer Dim best_prec As Integer 'Dim primatives As Object Dim operators As Variant Dim i As Long ' Setup primatives ' Set primatives = CreateObject("Scripting.Dictionary") ' primatives.Add "PI", (4 * Atn(1)) ' '(insert additional primatives here, as needed) ' Setup list of G-code operators operators = Array("**", "*", "/", "mod", "+", "-", "or", "xor", "mod") ' Remove all spaces. expr = Replace_(Expression, " ", "") expr_len = Len(expr) If expr_len = 0 Then EvaluateExpression = 0 Exit Function End If ' If we find + or - now, it is a unary operator. is_unary = True ' So far we have nothing. best_prec = PREC_NONE ' Find the operator with the lowest precedence. ' Look for places where there are no open ' parentheses. For pos = 1 To expr_len ' Examine the next character. ch = LCase$(Mid$(expr, pos, 1)) ' Assume we will not find an operator. In ' that case, the next operator will not ' be unary. next_unary = False If ch = " " Then ' Just skip spaces. We keep them here ' to make the error messages easier to ElseIf ch = "[" Then ' Increase the open parentheses count. parens = parens + 1 ' A + or - after "[" is unary. next_unary = True ElseIf ch = "]" Then ' Decrease the open parentheses count. parens = parens - 1 ' An operator after "]" is not unary. next_unary = False ' If parens < 0, too many ']'s. If parens < 0 Then RaiseError -1 End If ElseIf parens = 0 Then ' Try to match an operator For i = LBound(operators) To UBound(operators) ch2 = LCase$(Mid$(expr, pos, Len(operators(i)))) If ch2 = operators(i) Then Exit For Else ch2 = "" End If Next i If ch2 <> "" Then ' An operator after an operator ' is unary. next_unary = True ' See if this operator has higher ' precedence than the current one. If ch2 = "**" Then If best_prec >= PREC_POWER Then best_prec = PREC_POWER best_pos = pos best_len = Len(ch2) pos = pos + (best_len - 1) End If ElseIf ch2 = "*" Or ch2 = "/" Or ch2 = "mod" Then If best_prec >= PREC_TIMES Then best_prec = PREC_TIMES best_pos = pos best_len = Len(ch2) pos = pos + (best_len - 1) End If ElseIf ch2 = "+" Or ch2 = "-" Or ch2 = "or" Or ch2 = "xor" Or ch2 = "and" Then ' Ignore unary operators ' for now. If (Not is_unary) And _ best_prec >= PREC_PLUS _ Then best_prec = PREC_PLUS best_pos = pos best_len = Len(ch2) pos = pos + (best_len - 1) End If End If End If End If is_unary = next_unary Next pos ' If the parentheses count is not zero, ' there's a ']' missing. If parens <> 0 Then RaiseError -1 End If ' Hopefully we have the operator. If best_prec < PREC_NONE Then lexpr = Left$(expr, best_pos - 1) rexpr = Mid$(expr, best_pos + best_len) opr = LCase$(Mid$(expr, best_pos, best_len)) If opr <> "" And lexpr = "" Or rexpr = "" Then ' Check for syntax error in expression RaiseError -1 End If If opr = "**" Then EvaluateExpression = EvaluateExpression(lexpr) ^ EvaluateExpression(rexpr) ElseIf opr = "*" Then EvaluateExpression = EvaluateExpression(lexpr) * EvaluateExpression(rexpr) ElseIf opr = "/" Then '?????????????????????????????????????????????????????????????????????????????????????????????????????? '?????????????????????????????????????????????????????????????????????????????????????????????????????? '?????????????????????????????????????????????????????????????????????????????????????????????????????? Dim LHS As Double Dim RHS As Double MsgBox "NOW YOU SEE IT: " & lexpr MsgBox "NOW YOU SEE IT: " & rexpr LHS = EvaluateExpression(lexpr) MsgBox "NOW YOU DON'T SEE IT (WHEN RUN IN MACH3 CB): " & lexpr MsgBox "NOW YOU DON'T SEE IT (WHEN RUN IN MACH3 CB): " & rexpr RHS = EvaluateExpression(rexpr) '?????????????????????????????????????????????????????????????????????????????????????????????????????? '?????????????????????????????????????????????????????????????????????????????????????????????????????? '?????????????????????????????????????????????????????????????????????????????????????????????????????? EvaluateExpression = LHS / RHS ElseIf opr = "mod" Then EvaluateExpression = EvaluateExpression(lexpr) Mod EvaluateExpression(rexpr) ElseIf opr = "+" Then EvaluateExpression = EvaluateExpression(lexpr) + EvaluateExpression(rexpr) ElseIf opr = "-" Then EvaluateExpression = EvaluateExpression(lexpr) - EvaluateExpression(rexpr) ElseIf opr = "or" Then EvaluateExpression = Gcode_OR(EvaluateExpression(lexpr), EvaluateExpression(rexpr)) ElseIf opr = "xor" Then EvaluateExpression = Gcode_XOR(EvaluateExpression(lexpr), EvaluateExpression(rexpr)) ElseIf opr = "and" Then EvaluateExpression = Gcode_AND(EvaluateExpression(lexpr), EvaluateExpression(rexpr)) End If Exit Function End If ' If we do not yet have an operator, there ' are several possibilities: ' ' 1. expr is [expr2] for some expr2. ' 2. expr is #expr2 or -expr2 or +expr2 for some expr2. ' 3. expr is Fun(expr2) for a function Fun. ' 4. expr is a primitive. ' 5. It's a literal like "3.14159". ' Look for [expr2] If Left$(expr, 1) = "[" And Right$(expr, 1) = "]" Then ' Remove the parentheses. EvaluateExpression = EvaluateExpression( _ Mid$(expr, 2, expr_len - 2)) Exit Function End If ' Look for #expr2. If Left$(expr, 1) = "#" Then EvaluateExpression = Mach3_GetParameterValue(EvaluateExpression(Mid$(expr, 2))) Exit Function End If ' Look for -expr2. If Left$(expr, 1) = "-" Then EvaluateExpression = -EvaluateExpression(Mid$(expr, 2)) Exit Function End If ' Look for +expr2. If Left$(expr, 1) = "+" Then EvaluateExpression = EvaluateExpression(Mid$(expr, 2)) Exit Function End If ' Look for Fun(expr2). If expr_len > 5 And Right$(expr, 1) = "]" Then ' Find the first [. pos = InStr(expr, "[") If pos > 0 Then ' See what the function is. lexpr = LCase$(Left$(expr, pos - 1)) rexpr = Mid$(expr, pos + 1, expr_len - pos - 1) Select Case lexpr Case "abs" EvaluateExpression = _ Gcode_ABS(EvaluateExpression(rexpr)) Exit Function Case "sqrt" EvaluateExpression = _ Gcode_SQRT(EvaluateExpression(rexpr)) Exit Function Case "exp" EvaluateExpression = _ Gcode_EXP(EvaluateExpression(rexpr)) Exit Function Case "fix" EvaluateExpression = _ Gcode_FIX(EvaluateExpression(rexpr)) Exit Function Case "fup" EvaluateExpression = _ Gcode_FUP(EvaluateExpression(rexpr)) Exit Function Case "ln" EvaluateExpression = _ Gcode_LN(EvaluateExpression(rexpr)) Exit Function Case "round" EvaluateExpression = _ Gcode_ROUND(EvaluateExpression(rexpr)) Exit Function Case "sin" EvaluateExpression = _ Gcode_SIN(EvaluateExpression(rexpr)) Exit Function Case "cos" EvaluateExpression = _ Gcode_COS(EvaluateExpression(rexpr)) Exit Function Case "tan" EvaluateExpression = _ Gcode_TAN(EvaluateExpression(rexpr)) Exit Function Case "asin" EvaluateExpression = _ Gcode_ASIN(EvaluateExpression(rexpr)) Exit Function Case "acos" EvaluateExpression = _ Gcode_ACOS(EvaluateExpression(rexpr)) Exit Function Case "atan" EvaluateExpression = _ Gcode_ATAN(EvaluateExpression(rexpr)) Exit Function ' Add other functions (including ' program-defined functions) here. End Select End If End If ' See if it's a primitive. ' If primatives.Exists(expr) Then ' ' We found the primative. ' EvaluateExpression = CDbl(primatives(expr)) ' Exit Function ' End If ' It must be a literal like "2.71828". On Error Resume Next EvaluateExpression = CDbl(expr) status = Err.Number On Error GoTo 0 If status <> 0 Then RaiseError -1 End If End Function Private Function Mach3_GetParameterValue(ByVal VarNum As Long) As Double If VarNum > 32767 Then RaiseError -1 End If ' this calls the Mach3 to get the parameter value Mach3_GetParameterValue = 777# 'GetVar(CInt(VarNum)) End Function Private Function Radians(ByVal Value As Double) As Double Dim PI As Double: PI = 4 * Atn(1) Radians = Value * (PI / 180#) End Function Private Function Degrees(ByVal Value As Double) As Double Dim PI As Double: PI = 4 * Atn(1) Degrees = Value * (180# / PI) End Function ' BINARY OPERATIONS Private Function Gcode_AND(ByVal LHS As Double, _ ByVal RHS As Double) As Double If (LHS <> 0) And (RHS <> 0) Then Gcode_AND = 1 Else Gcode_AND = 0 End If End Function Private Function Gcode_OR(ByVal LHS As Double, _ ByVal RHS As Double) As Double If (LHS <> 0) Or (RHS <> 0) Then Gcode_OR = 1 Else Gcode_OR = 0 End If End Function Private Function Gcode_XOR(ByVal LHS As Double, _ ByVal RHS As Double) As Double If (LHS <> 0) Xor (RHS <> 0) Then Gcode_XOR = 1 Else Gcode_XOR = 0 End If End Function Private Function Gcode_MOD(ByVal LHS As Double, _ ByVal RHS As Double) As Double Gcode_MOD = LHS Mod RHS End Function ' UNARY OPERATIONS Private Function Gcode_ABS(ByVal Value As Double) As Double Gcode_ABS = Abs(Value) End Function Private Function Gcode_SQRT(ByVal Value As Double) As Double Gcode_SQRT = Sqr(Value) End Function Private Function Gcode_EXP(ByVal Value As Double) As Double Gcode_EXP = Exp(Value) End Function Private Function Gcode_LN(ByVal Value As Double) As Double Gcode_LN = Log(Value) End Function Private Function Gcode_ROUND(ByVal Value As Double) As Double Gcode_ROUND = Round(Value) End Function Private Function Gcode_FUP(ByVal Value As Double) As Double Gcode_FUP = Fix(Value + 0.5) End Function Private Function Gcode_FIX(ByVal Value As Double) As Double Gcode_FIX = Fix(Value - 0.5) End Function Private Function Gcode_SIN(ByVal Value As Double) As Double Gcode_SIN = Sin(Radians(Value)) End Function Private Function Gcode_COS(ByVal Value As Double) As Double Gcode_COS = Cos(Radians(Value)) End Function Private Function Gcode_TAN(ByVal Value As Double) As Double Gcode_TAN = Tan(Radians(Value)) End Function Private Function Gcode_ASIN(ByVal Value As Double) As Double Dim PI As Double: PI = 4 * Atn(1) If (Sqr(1 - Value * Value) <= 0.000000000001) And _ (Sqr(1 - Value * Value) >= -0.000000000001) Then Gcode_ASIN = Degrees(PI / 2) Else Gcode_ASIN = Degrees(Atn(Value / Sqr(-Value * Value + 1))) End If End Function Private Function Gcode_ACOS(ByVal Value As Double) As Double Dim PI As Double: PI = 4 * Atn(1) Dim x As Double: x = Round(Value, 8) If x = 1 Then Gcode_ACOS = 0 ElseIf x = -1 Then Gcode_ACOS = Degrees(PI) Else Gcode_ACOS = Degrees(Atn(-Value / Sqr(-Value * Value + 1)) + 2 * Atn(1)) End If End Function Private Function Gcode_ATAN(ByVal Value As Double) As Double Gcode_ATAN = Degrees(Atn(Value)) End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Replace_(ByVal Expression As String, _ ByVal FindStr As String, _ ByVal ReplaceStr As String) As String Const Start As Long = -1 Const Count As Long = -1 Const Compare As Long = 0 'vbBinaryCompare Dim sResult As String sResult = "" Dim p As Long Dim lLengthExpression As Long Dim lLengthFindStr As Long Dim lLengthReplaceStr As Long Dim lAccumulatedPos As Long Dim lReplaceCount As Long lLengthExpression = Len(Expression) lLengthFindStr = Len(FindStr) lAccumulatedPos = 1 If Count <> 0 And lLengthExpression > 0 And lLengthFindStr > 0 Then lLengthReplaceStr = Len(ReplaceStr) If Start = -1 Then p = 1 Else p = Start End If Do While (p > 0 And p <= lLengthExpression) p = InStr(p, Expression, FindStr, Compare) If p > 0 Then sResult = sResult & Mid$(Expression, lAccumulatedPos, p - lAccumulatedPos) & ReplaceStr p = p + lLengthFindStr lAccumulatedPos = p If Count <> -1 Then lReplaceCount = lReplaceCount + 1 If lReplaceCount >= Count Then Exit Do End If End If End If Loop End If If lAccumulatedPos > 1 Then If lAccumulatedPos <= lLengthExpression Then Replace_ = sResult & Mid$(Expression, lAccumulatedPos) Else Replace_ = sResult End If Else Replace_ = Expression End If End Function Private Sub RaiseError(ByVal ResultCode As Long) MsgBox ResultCode End Sub