'============================================================================== ' ' vbcalc.bas - expression calculator ' ' Written: 95/04/02 Pieter Hintjens ' Revised: 95/04/21 ' ' Skeleton generated by LIBERO 2.10 on 21 Apr, 1995, 16:37. '============================================================================== ' Option Explicit ' ' Define module-level variables here ' Const end_mark_priority = 1 ' Relative priority of tokens Const left_par_priority = 2 ' which may occur in exression Const right_par_priority = 3 ' - higher number means higher Const term_op_priority = 4 ' priority, ie. executed first. Const factor_op_priority = 5 Const lowest_op_priority = 4 Const end_mark_token = "$" ' Indicates end of operator stack Const operator_max = 29 ' Max size of operator stack Dim operator_ptr As Integer ' Current size of operator stack Dim op_token(operator_max) As String Dim op_priority(operator_max) As Integer Const operand_max = 29 ' Max size of operand stack Dim operand_ptr As Integer ' Current size of operand stack Dim op_number(operand_max) As Long Dim op_1 As Long Dim op_2 As Long ' Operands used in calculations Dim the_number As Long ' Value of number in expression Dim expr_ptr As Integer ' Offset to next char to parse Dim token_posn As Integer ' Offset of last token parsed Dim the_token As String ' Current expression token Dim the_operator As String ' Operator to execute Dim the_priority As Integer ' Priority of current token Dim cur_sign As String ' Sign for signed number ' ' Arguments for function ' Dim expr As String Dim result As Long ' ' Events that you defined in the dialog ' Const terminate_event = -1 ' Halts the dialog '%BEGIN EVENTS '---------------------------------------------------------------------------- ' Dialog event definitions - do not modify this code by hand ' Generated by LIBERO 2.10 on 7 Dec, 1995, 15:00. ' Schema used: lrschema.vb '---------------------------------------------------------------------------- Const terminate_event = -1 ' Halts the dialog Const end_mark_event = 0 Const error_event = 1 Const exception_event = 2 Const factor_op_event = 3 Const left_par_event = 4 Const number_event = 5 Const ok_event = 6 Const right_par_event = 7 Const term_op_event = 8 '%END EVENTS Dim the_next_event As Integer ' Next event from module Dim the_exception_event As Integer ' Exception event from module Dim exception_raised As Integer ' TRUE if exception raised Dim feedback As Integer ' Return code for function ' '************************** ALLOW SIGNED NUMBER *************************** ' Private Sub allow_signed_number () cur_sign = the_token If Mid$(expr, expr_ptr, 1) >= "0" And Mid$(expr, expr_ptr, 1) <= "9" Then the_token = Mid$(expr, expr_ptr, 1) expr_ptr = expr_ptr + 1 collect_number If cur_sign = "-" Then the_number = 0 - the_number End If ' Go handle number as operand in this state the_exception_event = number_event exception_raised = True End If End Sub ' Pick-up the_number at expr; 1 digit is already in Token Private Sub collect_number () Do While Mid$(expr, expr_ptr, 1) >= "0" And Mid$(expr, expr_ptr, 1) <= "9" the_token = the_token & Mid$(expr, expr_ptr, 1) expr_ptr = expr_ptr + 1 Loop the_number = Val(the_token) End Sub ' '*************************** GET EXTERNAL EVENT *************************** ' Private Sub get_external_event () End Sub ' '***************************** GET NEXT TOKEN ***************************** ' Private Sub get_next_token () Do While Mid$(expr, expr_ptr, 1) = " " expr_ptr = expr_ptr + 1 ' Skip spaces Loop token_posn = expr_ptr ' Save start of this token the_token = Mid$(expr, expr_ptr, 1) ' Get next token expr_ptr = expr_ptr + 1 ' and bump pointer Select Case the_token Case "+", "-" the_next_event = term_op_event the_priority = term_op_priority Case "*", "/" the_next_event = factor_op_event the_priority = factor_op_priority Case "(" the_next_event = left_par_event the_priority = left_par_priority Case ")" the_next_event = right_par_event the_priority = right_par_priority Case end_mark_token the_next_event = end_mark_event the_priority = end_mark_priority Case Else If the_token >= "0" And the_token <= "9" Then the_next_event = number_event collect_number Else signal_error "Invalid token: " & the_token End If End Select End Sub ' '************************* INITIALISE THE PROGRAM ************************* ' Private Sub initialise_the_program () result = 0 ' Assume result is zero operand_ptr = 0 ' Operand stack holds zero operator_ptr = 0 ' Operator stack holds end mark op_number(0) = 0 op_token(0) = end_mark_token op_priority(0) = end_mark_priority expr = expr & end_mark_token ' Append end-of-expression mark expr_ptr = 1 ' Move to start of expression the_next_event = ok_event End Sub ' Display message in box, set feedback to -1 for error Private Sub pop_up_error (message As String) MsgBox message, MB_OK, "Error in Expression" feedback = -1 End Sub ' Display message in box, and halt dialog with exception Private Sub signal_error (message As String) pop_up_error message the_exception_event = exception_event exception_raised = True End Sub ' '************************** SIGNAL INVALID TOKEN ************************** ' Private Sub signal_invalid_token () pop_up_error "Token is invalid at this point: " & the_token End Sub ' '************************** SIGNAL TOKEN MISSING ************************** ' Private Sub signal_token_missing () pop_up_error "Unexpected end of expression" End Sub ' '**************************** STACK THE NUMBER **************************** ' Private Sub stack_the_number () If operand_ptr < operand_max Then operand_ptr = operand_ptr + 1 op_number(operand_ptr) = the_number Else signal_error "Operand stack overflowed" End If End Sub ' '*************************** STACK THE OPERATOR *************************** ' Private Sub stack_the_operator () If operator_ptr < operator_max Then operator_ptr = operator_ptr + 1 op_token(operator_ptr) = the_token op_priority(operator_ptr) = the_priority Else signal_error "Operator stack overflowed" End If End Sub ' '************************* TERMINATE THE PROGRAM ************************* ' Private Sub terminate_the_program () the_next_event = terminate_event End Sub ' '************************* UNSTACK ALL OPERATORS ************************** ' Private Sub unstack_all_operators () Do While op_priority(operator_ptr) >= lowest_op_priority unstack_operator Loop End Sub ' '************************** UNSTACK GE OPERATORS ************************** ' Private Sub unstack_ge_operators () Do While op_priority(operator_ptr) >= the_priority unstack_operator Loop End Sub ' '************************** UNSTACK IF END MARK *************************** ' Private Sub unstack_if_end_mark () If op_token(operator_ptr) = end_mark_token Then unstack_operator Else signal_error "Right parenthesis is missing" End If End Sub ' '************************** UNSTACK IF LEFT PAR *************************** ' Private Sub unstack_if_left_par () If op_token(operator_ptr) = "(" Then operator_ptr = operator_ptr - 1 Else signal_error "Too many right parentheses in expression" End If End Sub Private Sub unstack_operator () the_operator = op_token(operator_ptr) operator_ptr = operator_ptr - 1 op_1 = op_number(operand_ptr) If InStr("+-*/", the_operator) Then ' Binary operator operand_ptr = operand_ptr - 1 op_2 = op_1 op_1 = op_number(operand_ptr) End If Select Case the_operator Case "+" op_1 = op_1 + op_2 Case "-" op_1 = op_1 - op_2 Case "*" op_1 = op_1 * op_2 Case "/" op_1 = op_1 / op_2 Case end_mark_token result = op_1 ' Return result value Case Else signal_error "Internal Error" End Select op_number(operand_ptr) = op_1 End Sub ' This is the entry function - change its name and arguments as you ' need to. If you expect arguments, copy them into module-level ' variables so that the private functions can access them. ' Function vbcalc (p_expr As String, p_result As Long) As Integer expr = p_expr If vbcalc_EXECUTE() Then ' Run program dialog vbcalc = -1 ' Error from dialog Else vbcalc = feedback ' Return feedback End If p_result = result End Function ' '****************************** DISPATCHER ******************************** ' Sub ZzDis_vbcalc (module, LR_nextev, LR_excpev, LR_raised) '%BEGIN DISPATCHER '------------------------------------------------------------------------ ' Dialog dispatcher - do not modify this code by hand ' Generated by LIBERO 2.10 on 7 Dec, 1995, 15:00. ' Schema used: lrschema.vb '----------------------------------------------------------lrschema.vb--- the_next_event = LR_nextev the_exception_event = LR_excpev exception_raised = LR_raised Select Case module Case -1 initialise_the_program Case -2 get_external_event Case 1 allow_signed_number Case 2 get_next_token Case 3 signal_invalid_token Case 4 signal_token_missing Case 5 stack_the_number Case 6 stack_the_operator Case 7 terminate_the_program Case 8 unstack_all_operators Case 9 unstack_ge_operators Case 10 unstack_if_end_mark Case 11 unstack_if_left_par End Select LR_nextev = the_next_event LR_excpev = the_exception_event LR_raised = exception_raised '%END DISPATCHER End Sub