Programmer 7500

home *** CD-ROM | disk | FTP | other *** search

/ Programmer 7500 / MAX_PROGRAMMERS.iso / VISUAL_B / CODIGO_2 / RPN_CAL / RPNCALC.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 1993-05-17 | 15.6 KB | 545 lines

VERSION 2.00 Begin Form Calculator BackColor = &H00C0C000& BorderStyle = 1 'Fixed Single Caption = "RPN Calculator" FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 4065 Icon = RPNCALC.FRX:0000 KeyPreview = -1 'True Left = 1110 LinkMode = 1 'Source LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 3540 ScaleWidth = 3690 Top = 3390 Width = 3810 Begin CommandButton Enter Caption = "Enter" Default = -1 'True Height = 1095 Left = 1920 TabIndex = 1 Top = 2400 Width = 495 End Begin CommandButton LastX Caption = "L" Height = 495 Left = 3120 TabIndex = 0 Top = 1800 Width = 495 End Begin CheckBox FixDec Caption = "Check1" Height = 255 Left = 240 TabIndex = 2 TabStop = 0 'False Top = 840 Width = 255 End Begin CommandButton Number Caption = "7" Height = 480 Index = 7 Left = 120 TabIndex = 3 TabStop = 0 'False Top = 1200 Width = 480 End Begin CommandButton Number Caption = "8" Height = 480 Index = 8 Left = 720 TabIndex = 4 TabStop = 0 'False Top = 1200 Width = 480 End Begin CommandButton Number Caption = "9" Height = 480 Index = 9 Left = 1320 TabIndex = 5 TabStop = 0 'False Top = 1200 Width = 480 End Begin CommandButton Number Caption = "4" Height = 480 Index = 4 Left = 120 TabIndex = 6 TabStop = 0 'False Top = 1800 Width = 480 End Begin CommandButton Number Caption = "5" Height = 480 Index = 5 Left = 720 TabIndex = 7 TabStop = 0 'False Top = 1800 Width = 480 End Begin CommandButton Number Caption = "6" Height = 480 Index = 6 Left = 1320 TabIndex = 8 TabStop = 0 'False Top = 1800 Width = 480 End Begin CommandButton Number Caption = "1" Height = 480 Index = 1 Left = 120 TabIndex = 9 TabStop = 0 'False Top = 2400 Width = 480 End Begin CommandButton Number Caption = "2" Height = 480 Index = 2 Left = 720 TabIndex = 10 TabStop = 0 'False Top = 2400 Width = 480 End Begin CommandButton Number Caption = "3" Height = 480 Index = 3 Left = 1320 TabIndex = 11 TabStop = 0 'False Top = 2400 Width = 480 End Begin CommandButton Number Caption = "0" Height = 480 Index = 0 Left = 120 TabIndex = 12 TabStop = 0 'False Top = 3000 Width = 1080 End Begin CommandButton Decimal Caption = "." Height = 480 Left = 1320 TabIndex = 13 TabStop = 0 'False Top = 3000 Width = 480 End Begin Image Pi Height = 480 Left = 3120 Picture = RPNCALC.FRX:0302 Top = 600 Width = 480 End Begin Image XSquare Height = 480 Left = 3120 Picture = RPNCALC.FRX:0604 Top = 1200 Width = 480 End Begin Label LabelFix Alignment = 2 'Center BackColor = &H00C0C000& Caption = "Fix 4" FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Left = 105 TabIndex = 14 Top = 600 Width = 510 End Begin Image Change Height = 480 Left = 2520 Picture = RPNCALC.FRX:0906 Top = 1800 Width = 480 End Begin Image SquareRoot Height = 480 Left = 2520 Picture = RPNCALC.FRX:0C08 Top = 1200 Width = 480 End Begin Image Up Height = 480 Left = 3120 Picture = RPNCALC.FRX:0F0A Top = 2400 Width = 480 End Begin Image Down Height = 480 Left = 2520 Picture = RPNCALC.FRX:120C Top = 2400 Width = 480 End Begin Image Plus Height = 480 Left = 1920 Picture = RPNCALC.FRX:150E Top = 1200 Width = 480 End Begin Image Minus Height = 480 Left = 1920 Picture = RPNCALC.FRX:1810 Top = 600 Width = 480 End Begin Image Devide Height = 480 Left = 720 Picture = RPNCALC.FRX:1B12 Top = 600 Width = 480 End Begin Image Mult Height = 480 Left = 1320 Picture = RPNCALC.FRX:1E14 Top = 600 Width = 480 End Begin Image SwapXY Height = 480 Left = 1920 Picture = RPNCALC.FRX:2116 Top = 1800 Width = 480 End Begin Image xby1 Height = 480 Left = 2520 Picture = RPNCALC.FRX:2418 Top = 600 Width = 480 End Begin Image Backspace Height = 480 Left = 2520 Picture = RPNCALC.FRX:271A Top = 3000 Width = 1080 End Begin Label Readout Alignment = 1 'Right Justify BackColor = &H00FFFF80& Caption = "0" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 13.5 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00000000& Height = 375 Index = 0 Left = 120 TabIndex = 15 Top = 120 Width = 3495 End ' ------------------------------------------------------------------------ ' Public Domain ' RPN Caculator ' ------------------------------------------------------------------------ Option Explicit Dim Register(0 To 5) As Variant ' RPN Registers ' 0 = Last X ' 1 = x ' 2 = y ' 3 = z ' 4 = t ' 5 = temp storage Dim DecimalFlag As Integer ' Decimal point present yet? Dim UserInput As String ' Numeric InPut String Dim UseStr As String ' Format Control String ' Event Functions ---------------------------------------------------------- '---------------------------------------------------------------------------- Sub BackSpace_Click () Call submit(Chr$(8)) End Sub Sub Change_Click () Call submit(Chr$(241)) End Sub ' Misc Functions ---------------------------------------------------------- Sub CheckInput () If Len(UserInput) > 0 Then Call PushUp Register(1) = Val(UserInput) Register(0) = Register(1) UserInput = "" DecimalFlag = False End If End Sub Sub Decimal_Click () Call submit(".") End Sub Sub Devide_Click () Call submit("/") End Sub Sub Devide0 () ' Devide by zero error display MsgBox "Attempted Devide by zero.", 48, "ERROR" End Sub Sub Down_Click () Call submit(Chr$(31)) End Sub Sub Enter_Click () Call submit(Chr$(13)) End Sub Sub FixDec_Click () If FixDec.Value = 1 Then UseStr = "###,###,###.0000;\-###,###,###.0000;0.0000;0.0" Else UseStr = "" End If Call Ok End Sub Sub Form_KeyDown (KeyCode As Integer, Shift As Integer) KeyCode = 0 End Sub Sub Form_KeyPress (KeyAscii As Integer) ' Readout(6).Caption = KeyAscii If KeyAscii = 27 Then End If KeyAscii = 8 Then Call submit(Chr$(8)) Dim k As String * 1 k = UCase$(Chr$(KeyAscii)) If InStr("0123456789XSRLC.+-*/=", k) Then Call submit(k) End If KeyAscii = 0 End Sub Sub Form_KeyUp (KeyCode As Integer, Shift As Integer) ' Readout(6).Caption = KeyCode ' NOTE: Contrary to the documentation the next line is useless ! If KeyCode = 13 Then Call submit(Chr$(13)) If KeyCode = 33 Then Call submit(Chr$(30)) If KeyCode = 34 Then Call submit(Chr$(31)) End Sub ' Initialization routine for the form. Sub Form_Load () Calculator.Caption = App.EXEName + ".EXE" If Left$(Calculator.Caption, 3) <> "RPN" Then Calculator.Caption = Calculator.Caption + " RPN" End If ' Calculator.Height = 5910 ' NOTE: Contrary to the documentation the next line is useless ! Calculator.KeyPreview = True Dim i As Integer For i = 0 To 5 Register(i) = 0 Next i UserInput = "0" Call CheckInput End Sub Sub LastX_Click () Call submit("L") End Sub Sub Minus_Click () Call submit("-") End Sub Sub Mult_Click () Call submit("*") End Sub Sub Number_Click (Index As Integer) Call submit(Chr$(48 + Index)) End Sub Sub Number_KeyUp (Index As Integer, KeyCode As Integer, Shift As Integer) If KeyCode = 13 Then Call submit(Chr$(13)) End Sub Sub Ok () If Len(UserInput) > 0 Then Readout(0) = UserInput Else Readout(0) = Format$(Register(1), UseStr) ' ReadOut(1) = Register(0) ' ReadOut(2) = Register(1) ' ReadOut(3) = Register(2) ' ReadOut(4) = Register(3) ' ReadOut(5) = Register(4) End If End Sub Sub Pi_Click () Call submit("P") End Sub Sub Plus_Click () Call submit("+") End Sub ' Stack Functions ---------------------------------------------------------- ' Push Registers down, T retains Value Sub PushDown () Register(1) = Register(2) Register(2) = Register(3) Register(3) = Register(4) End Sub ' Push Registers up, X retains value Sub PushUp () Register(4) = Register(3) Register(3) = Register(2) Register(2) = Register(1) End Sub ' Rotate Register x-t (1 to 4) down Sub RollDown () Register(5) = Register(1) ' Save X register Call PushDown Register(4) = Register(5) End Sub ' Rotate Register x-t (1 to 4) up Sub RollUp () Register(5) = Register(4) ' Save T register Call PushUp Register(1) = Register(5) End Sub Sub SquareRoot_Click () Call submit("R") End Sub ' Program Core --------------------------------------------------------------- ' All input is processed here. This Subroutine is used so that multiple ' events can be mapped to the same function: ' EXAMPLE: Image Enter_Click and KeyPress (Enter) ' It also allows for a future implimentation of *.RPN script files ' or the assingment userdefined functions. Sub submit (s As String) Select Case s Case "." ' Decimal Point If Len(UserInput) > 0 Then If DecimalFlag = False Then UserInput = UserInput + "." Else UserInput = "0." End If DecimalFlag = True Case "0" To "9" UserInput = UserInput + s Case "*" ' Multiply Y by X Call CheckInput Register(0) = Register(1) Register(2) = Register(2) * Register(1) Call PushDown Case "+" ' Add X to Y Call CheckInput Register(0) = Register(1) Register(2) = Register(2) + Register(1) Call PushDown Case "-" ' Sub X from Y Call CheckInput Register(0) = Register(1) Register(2) = Register(2) - Register(1) Call PushDown Case "/" ' Devide Y by X Call CheckInput If Abs(Register(1)) > 0 Then Register(0) = Register(1) Register(2) = Register(2) / Register(1) Call PushDown Else Call Devide0 End If Case "=" ' Exchange X and Y Call CheckInput Register(5) = Register(1) ' Save X register Register(1) = Register(2) Register(2) = Register(5) Case "X" ' X = 1/X Call CheckInput If Abs(Register(1)) > 0 Then Register(0) = Register(1) Register(1) = 1 / Register(1) Else Call Devide0 End If Case Chr$(241) ' Change Sign of X Call CheckInput Register(1) = -(Register(1)) Case Chr$(30) ' Roll Up Call CheckInput Call RollUp Case Chr$(31) ' Roll Down Call CheckInput Call RollDown Case "S" ' Square (X = X * X) Call CheckInput Register(1) = Register(1) * Register(1) Case "R" ' SquareRoot Call CheckInput Register(1) = Sqr(Abs(Register(1))) Case "P" ' Insert Value for Pi Call CheckInput UserInput = "3.141592654" Call CheckInput Case "L" ' Resstore last "X" value Call CheckInput UserInput = Register(0) Call CheckInput Case Chr$(8) ' BackSpace If Len(UserInput) > 0 Then If Right$(UserInput, 1) = "." Then DecimalFlag = False UserInput = Left$(UserInput, Len(UserInput) - 1) Else UserInput = "0" Call CheckInput End If Case Chr$(13) ' Enter Key If Len(UserInput) = 0 Then UserInput = Format$(Register(1)) End If Call CheckInput Case Else ' do nothing End Select Call Ok Calculator.Enter.SetFocus End Sub Sub SwapXY_Click () Call submit("=") End Sub Sub Up_Click () Call submit(Chr$(30)) End Sub Sub Xby1_Click () Call submit("X") End Sub Sub XSquare_Click () Call submit("S") End Sub