VERSION 5.00
Begin VB.Form calcw
BackColor = &H80000005&
Caption = "RPN calculator Ver.2006-02"
ClientHeight = 4500
ClientLeft = 48
ClientTop = 336
ClientWidth = 2880
BeginProperty Font
Name = "Times New Roman"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
KeyPreview = -1 'True
LinkTopic = "Form1"
ScaleHeight = 4500
ScaleWidth = 2880
StartUpPosition = 3 'Windows default
Begin VB.OptionButton radian
BackColor = &H80000009&
Caption = "Radian"
BeginProperty Font
Name = "Times New Roman"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 204
Left = 1920
TabIndex = 6
Top = 156
Width = 810
End
Begin VB.OptionButton degree
BackColor = &H80000009&
Caption = "Degree"
BeginProperty Font
Name = "Times New Roman"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 204
Left = 1080
TabIndex = 5
Top = 156
Value = -1 'True
Width = 810
End
Begin VB.TextBox regT
BackColor = &H80000000&
BeginProperty Font
Name = "Arial"
Size = 10.2
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 264
Left = 276
TabIndex = 4
Text = " 0"
Top = 456
Width = 2448
End
Begin VB.TextBox regZ
BackColor = &H80000000&
BeginProperty Font
Name = "Arial"
Size = 10.2
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 264
Left = 276
TabIndex = 3
Text = " 0"
Top = 756
Width = 2448
End
Begin VB.TextBox regY
BackColor = &H80000000&
BeginProperty Font
Name = "Arial"
Size = 10.2
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 264
Left = 276
TabIndex = 2
Text = " 0"
Top = 1056
Width = 2448
End
Begin VB.TextBox regX
BackColor = &H8000000E&
BeginProperty Font
Name = "Arial"
Size = 10.2
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 264
Left = 276
TabIndex = 1
Text = " 0"
Top = 1356
Width = 2448
End
Begin VB.TextBox dmy
Appearance = 0 'Flat
BackColor = &H00FFFF00&
BorderStyle = 0 'None
BeginProperty Font
Name = "Times New Roman"
Size = 7.8
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 192
Left = 2784
TabIndex = 0
Top = 4284
Width = 72
End
Begin VB.Image keypad
Height = 4500
Left = 0
Picture = "calcw.frx":0000
Stretch = -1 'True
Top = 0
Width = 2880
End
End
Attribute VB_Name = "calcw"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'
' calcw.frm (RPN calculator on Windows) coded by Tad.Nakatsuka
' Last updated 2006-02 (Ver.2006-02)
'
' This is a VisualBasic program to realize "RPN caculator" on a Windows.
' Additional image file "calcw.jpg" should be read into the bitmap picture
' of "keypad" Image contol (defined in this source).
' The author, T. Nakatsuka, does not insist any right on this program,
' i.e., free to re-distribute to any place with/without any modification.
' The author acknowledges Hewlett-Packard Corp. for their intelligent
' product of micro-calculators, which were borne in mind during designing.
'
Option Explicit
Private Kdeg As Integer, Key As Integer, M As Integer
Private L As Integer, Lce As Integer
Private X As Double, Y As Double, Z As Double, T As Double
Private R As Double, Tmp As Double
Private Xstr As String
Private Const Pi = 3.14159265358979
Private Const Hpi = Pi / 2#
Private Const Bnl = 2.71828182845905
Private Const A10 = 2.30258509299405 '[ A10 : ln(10.) ]
'
' Key : Status for Register-X
' = 0 : Register-X shall be cleared by New-Value entry
' [after ENTER/CLR/CLX/STO operation]
' = 1 : CHS input after Key=0
' = 2 : Register-X shall be pushed (on stack) by New-Value entry
' [after Arithmetic or SWAP/ROT operation,
' or definite value entry by RCL/'pi'/'e']
' = 3 : CHS input after Key=2
' =4-7: on the way of New-Value entry
' [after Numeric input keys (0-9/./EEX)]
' =4 : neither . nor EEX input yet
' =5 : . already input but EEX not yet
' =6 : EEX already input but no exponent digit yet
' =7 : at least 1 exponent digit input already
' = 8 : editting directly
' = 9 : error detected (click CLR/CLX or hit ESC to reset)
'
Private Sub showx()
If (Key = 9) Then
X = 0#: Xstr = " E R R O R !!": regX.Text = Xstr
Else
Xstr = Str(X): L = Len(Xstr): regX.Text = Xstr: Key = 2
End If
End Sub
Private Sub push(k As Integer)
T = Z: Z = Y
If (k = 0) Then Y = X Else Y = -X
regY.Text = Str(Y): regZ.Text = Str(Z): regT.Text = Str(T)
End Sub
Private Sub pop()
X = Y: Y = Z: Z = T
regZ.Text = Str(Z): regY.Text = Str(Y): showx
End Sub
Private Sub num(i As Integer)
If (Key < 4) Then
If (Key = 2) Then push (0) Else If (Key = 3) Then push (1)
If (Key = 0) Or (Key = 2) Then Xstr = " " Else Xstr = "-"
L = 1: Key = 4
End If
Xstr = Xstr + Right(Str(i), 1): L = L + 1
If (Key = 6) Then Key = 7
X = Val(Xstr): regX.Text = Xstr
End Sub
Private Sub dot()
If (Key < 4) Then
If (Key = 2) Then push (0) Else If (Key = 3) Then push (1)
If (Key = 0) Or (Key = 2) Then Xstr = " 0" Else Xstr = "-0"
L = 2: X = 0#
End If
Xstr = Xstr + ".": L = L + 1
Key = 5: regX.Text = Xstr
End Sub
Private Sub eex()
If (Key < 4) Then
If (Key = 2) Then push (0) Else If (Key = 3) Then push (1)
If (Key = 0) Or (Key = 2) Then Xstr = " 1." Else Xstr = "-1."
L = 3: X = Val(Xstr)
End If
Xstr = Xstr + "E": L = L + 1: Lce = L
Key = 6: regX.Text = Xstr
End Sub
Private Sub chs()
If (Key < 6) Then
If (Key = 0) Then Key = 1 Else If (Key = 1) Then Key = 0
If (Key = 2) Then Key = 3 Else If (Key = 3) Then Key = 2
If (Left(Xstr, 1) = " ") Then
Xstr = "-" + Right(Xstr, L - 1)
Else
Xstr = " " + Right(Xstr, L - 1)
End If
X = -X
ElseIf (Key = 6) Then
If (Mid(Xstr, Lce, 1) = "E") Then
Xstr = Xstr + "-": L = L + 1: Lce = L
Else
L = L - 1: Lce = L: Xstr = Left(Xstr, L)
End If
ElseIf (Key = 7) Then
If (Mid(Xstr, Lce, 1) = "E") Then
Xstr = Left(Xstr, Lce) + "-" + Right(Xstr, L - Lce)
L = L + 1: Lce = Lce + 1
Else
L = L - 1: Lce = Lce - 1
Xstr = Left(Xstr, Lce) + Right(Xstr, L - Lce)
End If
X = Val(Xstr)
End If
regX.Text = Xstr
End Sub
Private Sub angl(k As Integer)
On Error GoTo perr
If (Kdeg = 1) Then
If (k = 1) Then X = X * 57.2957795130823 Else X = X / 57.2957795130823
End If
Exit Sub
perr: Key = 9: Resume Next
End Sub
Private Sub degree_MouseDown(bt%, sh%, fx As Single, fy As Single)
If (Kdeg = 0) Then
Kdeg = 1: degree.Value = True: radian.Value = False
End If
dmy.SetFocus
End Sub
Private Sub radian_MouseDown(bt%, sh%, fx As Single, fy As Single)
If (Kdeg = 1) Then
Kdeg = 0: degree.Value = False: radian.Value = True
End If
dmy.SetFocus
End Sub
Private Sub regT_GotFocus()
regT.BackColor = &H8080FF
End Sub
Private Sub regT_LostFocus()
regT.BackColor = &H80000000: dmy.SetFocus
End Sub
Private Sub regT_Change()
regT.Text = Str(T)
End Sub
Private Sub regT_KeyPress(kc As Integer)
If (kc = &H1B) Or (kc = &HD) Then regT_LostFocus
End Sub
Private Sub regZ_GotFocus()
regZ.BackColor = &H8080FF
End Sub
Private Sub regZ_LostFocus()
regZ.BackColor = &H80000000: dmy.SetFocus
End Sub
Private Sub regZ_Change()
regZ.Text = Str(Z)
End Sub
Private Sub regZ_KeyPress(kc As Integer)
If (kc = &H1B) Or (kc = &HD) Then regZ_LostFocus
End Sub
Private Sub regY_GotFocus()
regY.BackColor = &H8080FF
End Sub
Private Sub regY_LostFocus()
regY.BackColor = &H80000000: dmy.SetFocus
End Sub
Private Sub regY_Change()
regY.Text = Str(Y)
End Sub
Private Sub regY_KeyPress(kc As Integer)
If (kc = &H1B) Or (kc = &HD) Then regY_LostFocus
End Sub
Private Sub regX_GotFocus()
regX.BackColor = &H8080FF
End Sub
Private Sub regX_LostFocus()
regX.BackColor = &H8000000E: dmy.SetFocus
End Sub
Private Sub regX_Change()
If (Key = 9) Then regX.Text = Xstr
If (Xstr <> regX.Text) Then
Xstr = regX.Text: X = Val(Xstr): Key = 8
End If
End Sub
Private Sub regX_KeyPress(kc As Integer)
If (kc = &H1B) Or (kc = &HD) Then
dmy.SetFocus: showx
If (Key = 9) Then kc = 0 Else Key = 2
End If
End Sub
Private Sub dmy_KeyPress(kc As Integer)
If (Key < 9) Then
On Error GoTo perr
Select Case (kc) '[ Only limited key inputs are supported ]
Case Asc("0") To Asc("9"): num (kc - Asc("0")) '[ "0"-"9" ]
Case Asc("C"), Asc("c"): chs '[ C(c) for ch +/- ]
Case Asc("E"), Asc("e"): If (Key < 6) Then eex '[ E(e) for Eex ]
Case Asc("."): If (Key < 5) Then dot '[ decimal point ]
Case Asc("*"): Y = Y * X: pop '[ arithmetic *,/,+,- ]
Case Asc("/"): Y = Y / X: pop
Case Asc("+"): Y = Y + X: pop
Case Asc("-"): If (Key = 6) Then chs '[ Only after Eex, "-" ]
If (Key <> 6) Then '[ may be used to ch +/- ]
Y = Y - X: pop
End If
Case &HD: push (0): showx: Key = 0 '[ Enter ]
End Select
End If
If (kc = &H1B) Then
Key = 0: showx: Key = 0 '[ Finalize Input, Clear ERROR ]
End If
kc = 0: Exit Sub
perr: Key = 9: Resume Next
End Sub
Private Sub keypad_MouseDown(bt%, sh%, fx As Single, fy As Single)
dmy.SetFocus
If (fx < 240!) Or (2639! < fx) Or (fy < 1740!) Or (4139! < fy) Then
M = 20
Else
M = (7 - ((Int(fy) - 1740) \ 300)) * 5 + ((Int(fx) - 240) \ 480)
If (M = 20) Then M = 21
End If
If (M = 19) Then '[ CLX ]
X = 0#: Key = 0: showx: Key = 0
ElseIf (M = 24) Then '[ CLR ]
X = 0#: Y = 0#: Z = 0#: R = 0#: push (0): Key = 0: showx: Key = 0
ElseIf (Key < 9) Then
On Error GoTo perr
Select Case (M)
Case 22: chs '[ ch +/- ]
Case 23: If (Key < 6) Then eex '[ Eex ]
Case 2: If (Key < 5) Then dot '[ decimal point ]
Case 1: num (0) '[ numerical digit 0-9 ]
Case 6, 7, 8: num (M - 5)
Case 11, 12, 13: num (M - 7)
Case 16, 17, 18: num (M - 9)
Case 3: '[ 'PI' ]
If (Key = 3) Then push (1) Else If (Key >= 2) Then push (0)
X = Pi: If (Key = 1) Or (Key = 3) Then X = -X
showx
Case 4: '[ 'e' ]
If (Key = 3) Then push (1) Else If (Key >= 2) Then push (0)
X = Bnl: If (Key = 1) Or (Key = 3) Then X = -X
showx
Case 14: R = X: showx: Key = 0 '[ STO ]
Case 9: '[ RCL ]
If (Key = 3) Then push (1) Else If (Key >= 2) Then push (0)
X = R: If (Key = 1) Or (Key = 3) Then X = -X
showx
Case 0: Y = Y + X: pop '[ arithmetic +,-,*,/ ]
Case 5: Y = Y - X: pop
Case 10: Y = Y * X: pop
Case 15: Y = Y / X: pop
Case 25: Y = Exp(Log(Y) * X): pop
Case 21: push (0): showx: Key = 0 '[ Enter ]
Case 29: Tmp = X: pop: T = Tmp: regT.Text = Str(T) '[ rot ]
Case 28: Tmp = X: X = Y: Y = Tmp '[ swap ]
regY.Text = Str(Y): showx
Case 26: If (X = 0#) Then GoTo derr '[ 1./x ]
X = 1# / X: showx
Case 27: If (X < 0#) Then GoTo derr '[ sqrt ]
X = Sqr(X): showx
Case 30: X = Exp(X): showx '[ exp ]
Case 31: If (X <= 0#) Then GoTo derr '[ ln ]
X = Log(X): showx
Case 35: X = Exp(A10 * X): showx '[ 10**x ]
Case 36: If (X <= 0#) Then GoTo derr '[ Log10 ]
X = Log(X) / A10: showx
Case 32: angl (0): X = Sin(X): showx '[ sin ]
Case 33: angl (0): X = Cos(X): showx '[ cos ]
Case 34: angl (0): X = Tan(X): showx '[ tan ]
Case 37: If (X > 1#) Or (X < -1#) Then GoTo derr '[ arcsin ]
If (X > 0.707) Then
X = Hpi - Atn(Sqr(1# - X * X) / X)
ElseIf (X > -0.707) Then
X = Atn(X / Sqr(1# - X * X))
Else
X = -Hpi - Atn(Sqr(1# - X * X) / X)
End If
angl (1): showx
Case 38: If (X > 1#) Or (X < -1#) Then GoTo derr '[ arccos ]
If (X > 0.707) Then
X = Atn(Sqr(1# - X * X) / X)
ElseIf (X > -0.707) Then
X = Hpi - Atn(X / Sqr(1# - X * X))
Else
X = Pi + Atn(Sqr(1# - X * X) / X)
End If
angl (1): showx
Case 39: X = Atn(X): angl (1): showx '[ arctan ]
End Select
End If
Exit Sub
derr: Key = 9: showx: Exit Sub
perr: Key = 9: Resume Next
End Sub
Private Sub Form_Initialize()
degree.Value = True: radian.Value = False: Kdeg = 1
Xstr = " 0": L = 1: Lce = 0: Key = 0
X = 0#: Y = 0#: Z = 0#: T = 0#: R = 0#
End Sub