Exercice : Source d'une Calculatrice en VB6 [Sources]

**SfJ5Rpw8** · 10/04/2009, 19h40

Bonjour ce Week-end Pascal s'annonçant pluvieux

Je vous propose, un petite exercice ..

la création d'un calculatrice en VB6..

Pour ouvrir le BAL, voici ma première création :

http://bbil.developpez.com/sources/vb6/calcVB6-01/

Elle est simple ,pas forcément pas terminée,.. , un peu tordue dans la gestion des flags de mémorisation ....Mais en gros elle fonctionne...

Je vous propose d'utiliser cette discussion
soit pour commenter ce premier source..
soit pour proposer vos créations ..

Les meilleures créations trouverons leur place dans notre page source ..

à vos claviers

**bidou** · 11/04/2009, 00h24

Amusons nous alors.

Un clone de la calculette 'standard' windows, la aussi largement améliorable

http://bidou.developpez.com/outils/calc.frm

**ProgElecT** · 11/04/2009, 14h02

Pour faire vivre un peu cette discussion.
La calculatrice

La page d'aide

Soyez tolérant, ce source je l’avais fait en prévision du passage a l’EURO, pour les commerciaux de là où je travaillais, je n’ai volontairement pas retouché le source, bien qu’il y aurai des améliorations à y faire, au vue de ce que j’ai appris depuis grâce à notre site préféré (DVP).
Tout ceci pour bien faire voir que l’on peut évoluer dans sa façon d’écrire du code au cours des années qui passent.

**Delbeke** · 11/04/2009, 15h56

Personellement, j'ai toujours regrété qu'il n'existe pas de calculatrice programmable(Un comble pour un ordinateur). C'est un projet que j'avais abordé il y a bien lngtemps et que je n'ai jamais fini, mais il avait produit mon composant DiEval6.ocx. Seul rescapé de mes divagations d'alors.

**medkarim** · 05/05/2009, 08h42

c'est bien cette discussion. elle m'a permis de sortir les vieux projets du carton.

ce n'est pas vraiment une calculatrice. mais peut servir comme telle. on peut lui faire faire autre chose.

Note: faut que MSscriptcontrol soit installé

**SfJ5Rpw8** · 05/05/2009, 21h17

merci medkarim pour ta contribution j'ai rajouté une image pour donnez des idées à d'autres contributeurs ...

**Xsat1** · 13/02/2010, 17h51

petite participation de ma part.

La calculatrice la plus SIMPLE qu'il puisse exister, c'est d'ailleurs le tout premier programme que j'ai développé à l'école cette année !

Et ici une version un peu plus améliorée mais faites pas attention au design, je m'en fou un peu de ça dans mes débuts, j'essaie que le code soit impeccable

Voili voilou

**nathanscott** · 17/08/2011, 21h53

J'ai moi aussi un peut travailler sur une calculette. C'est pas encore parfait, mais je compte beaucoup sur votre aide et vos critiques pour la parfaire.

**SfJ5Rpw8** · 18/08/2011, 00h02

Envoyé par nathanscott

J'ai moi aussi un peut travailler sur une calculette. C'est pas encore parfait, mais je compte beaucoup sur votre aide et vos critiques pour la parfaire.

Il s'agit d'une version .Net tu devrais poste ton code la partie "Téléchargez" de VB.Net ici :

http://vb.developpez.com/telecharger...rie/324/Divers

**Montor** · 07/09/2012, 22h02

C'est un peut trop tard pour moi mais rien empeche de mettre ma contribution "il s'agit d'un interpréteur d'expression "
bienque on ne utilise ce genre de code que dans rare cas.. créer un calculateur reste une excercice de style rien de plus

classe CLexer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
Option Explicit
Private Declare Function RtlMoveMemory Lib "kernel32" (ByVal Dest As Long, _
          ByVal Source As Long, ByVal iCount As Long) As Long
Private Declare Function GetLocaleInfoA Lib "kernel32" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As Long, ByVal cchData As Long) As Long
Private Declare Function GetThreadLocale Lib "kernel32" () As Long
Const LOCALE_SDECIMAL = &HE
Public Enum TokenType
   tkInvalid = 1000
   tkNone = 0
   tkWhite = 1
   tkNumber = 2
   tkIdent = 3
   tkOpPow = 4
   tkOpenExp = 5
   tkCloseExp = 6
   tkOpenBra = 7
   tkCloseBra = 8
   tkOpNot = 9
   OpTermBegin = 100
     tkOpOr = 101
     tkOpXor = 102
     tkOpPlus = 103
     tkOpMinus = 104
   OpTermEnd = 105
   OpFacBegin = 200
     tkOpMul = 201
     tkOpMod = 202
     tkOpDivF = 203
     tkOpDiv = 204
     tkOpAnd = 205
     tkOpShl = 206
     tkOpShr = 207
   OpFacEnd = 208
End Enum
 
Private DecimalSep As Long
Private fCode As String
Private fPtr As Long
Private fLen As Long
Private fPos As Long
Private fCopyStart As Long
Private Char As Long
Public CurrToken As TokenType
 
Private Sub Class_Initialize()
   'Récupère le séparateur décimal
   If GetLocaleInfoA(GetThreadLocale, LOCALE_SDECIMAL, VarPtr(DecimalSep), 4) = 0 Then
        DecimalSep = 44
   End If
End Sub
 
Private Function GetChar(ByVal Idx As Long) As Long
   If (Idx < fLen) And (Idx >= 0) Then
     RtlMoveMemory VarPtr(GetChar), fPtr + Idx * 2, 1
   End If
   Char = GetChar
End Function
 
Private Function IdentType(ByVal AIdent As String) As TokenType
      Select Case AIdent
         Case "MOD": IdentType = tkOpMod
         Case "DIV": IdentType = tkOpDiv
         Case "AND": IdentType = tkOpAnd
         Case "OR":  IdentType = tkOpOr
         Case "XOR": IdentType = tkOpXor
         Case "NOT": IdentType = tkOpNot
         Case "SHL": IdentType = tkOpShl
         Case "SHR": IdentType = tkOpShr
      Case Else
         IdentType = tkIdent
      End Select
End Function
 
Private Function CharType(ByVal Char As Long) As TokenType
   Select Case Char
        Case 97 To 122, 65 To 90  ' a..z,A..Z alpha
           CharType = tkIdent
        Case 1 To 32: CharType = tkWhite   'blanc
        Case 48 To 57: CharType = tkNumber '0..9
        Case 45: CharType = tkOpMinus '-
        Case 43: CharType = tkOpPlus  '+
        Case 42: CharType = tkOpMul   '*
        Case 47: CharType = tkOpDivF  '/
        Case 94: CharType = tkOpPow   '^
        Case 40: CharType = tkOpenExp  '(
        Case 41: CharType = tkCloseExp ')
        Case 91: CharType = tkOpenBra  '[
        Case 93: CharType = tkCloseBra ']
        Case 0:  CharType = tkNone     '#0
        Case Else
           CharType = tkInvalid
   End Select
End Function
 
Private Sub LoadCharSet(ByVal AG As TokenType)
    While CharType(GetChar(fPos + 1)) = AG
       fPos = fPos + 1
    Wend
End Sub
 
Private Function NextChar() As Integer
     fPos = fPos + 1
     NextChar = GetChar(fPos)
End Function
 
Public Function NextToken() As TokenType
   While CharType(GetChar(fPos)) = tkWhite
     fPos = fPos + 1
   Wend
   fCopyStart = fPos
   CurrToken = CharType(Char)
   Select Case CurrToken
     Case tkIdent
         LoadCharSet tkIdent
     Case tkNumber
     '[0-9]+ (.[0-9]+)? (E|e(-|+)? [0-9]+)?
         LoadCharSet tkNumber
         If Char = DecimalSep Then  ', or .
            NextChar
            LoadCharSet tkNumber
         End If
         If (Char = 69) Or (Char = 101) Then 'E e
            NextChar
            If (GetChar(fPos + 1) = 43) Or (Char = 45) Then ' - +
                NextChar
            End If
            LoadCharSet tkNumber
         End If
   End Select
   If fPos < fLen Then
      fPos = fPos + 1
   End If
   If CurrToken = tkIdent Then
      CurrToken = IdentType(Token)
   End If
   NextToken = CurrToken
End Function
 
Public Property Let Text(ACode As String)
   fCode = ACode
   fPtr = StrPtr(fCode)
   fLen = Len(fCode)
   fPos = 0
   fCopyStart = 0
End Property
 
Public Property Get Token() As String
Dim L As Long
   L = fPos - fCopyStart
   If (L <= fLen) And (L >= 0) Then
    Token = Space(L)
    RtlMoveMemory StrPtr(Token), fPtr + fCopyStart * 2, L * 2
    Token = UCase$(Token)
   End If
End Property
 
Public Property Get Position() As String
    Position = fPos
End Property

classe CExpression

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
Option Explicit
 
Private fLexer As New CLexer
 
Private Property Get CurrentToken() As TokenType
     CurrentToken = fLexer.CurrToken
End Property
 
Private Function NextToken() As TokenType
     NextToken = fLexer.NextToken
     SynErr fLexer.CurrToken = tkInvalid
End Function
 
Private Function IsUnairyOp(ByVal AOP As TokenType) As Boolean
   Select Case AOP
        Case tkOpNot, tkOpPlus, tkOpMinus
             IsUnairyOp = True
   End Select
End Function
 
Private Function IsFacOperator(ByVal AOP As TokenType) As Boolean
   IsFacOperator = ((AOP > OpFacBegin) And (AOP < OpFacEnd))
End Function
 
Private Function IsTermOperator(ByVal AOP As TokenType) As Boolean
   IsTermOperator = ((AOP > OpTermBegin) And (AOP < OpTermEnd))
End Function
'<Factor> ::= (+|-)<Expression>| NUMBER | <Simple Call> | CONSTANT |'('<Expression>')' | '['<Expression>']' | NULL
Private Function GetFactor() As Double
Dim UOP As TokenType
Dim Ret As Double
Dim Ident As String
    If IsUnairyOp(NextToken) Then
       UOP = CurrentToken
       Ret = GetExpression()
       UnairyOperation UOP, Ret
    Else
      Select Case CurrentToken
        Case tkNumber
              Ret = CDbl(fLexer.Token)
        Case tkIdent
              Ident = fLexer.Token
              If Not GetConstValue(Ret, Ident) Then
                 SynErr NextToken <> tkOpenExp
                 Ret = Simple_Call(GetExpression, Ident)
                 SynErr CurrentToken <> tkCloseExp
              End If
        Case tkOpenExp
              Ret = GetExpression
              SynErr CurrentToken <> tkCloseExp
        Case tkOpenBra
              Ret = GetExpression
              SynErr CurrentToken <> tkCloseBra
        Case tkNone
              Ret = 0
        Case Else
              SynErr
      End Select
      NextToken
    End If
    GetFactor = Ret
End Function
'<Exp> ::= <Factor>(^<Factor>)*
Private Function GetExp() As Double
     GetExp = GetFactor
     While CurrentToken = tkOpPow
           BinaryOperation CurrentToken, GetExp, GetFactor
     Wend
End Function
'<Term> ::= <Exp> (DIV | * | / | MOD ... <Exp>)*
Private Function GetTerm() As Double
     GetTerm = GetExp
     While IsFacOperator(CurrentToken)
           BinaryOperation CurrentToken, GetTerm, GetExp
     Wend
End Function
'<Expression>  ::= <Term> (+|- ... <Term>)*
Private Function GetExpression() As Double
     GetExpression = GetTerm
     While IsTermOperator(CurrentToken)
           BinaryOperation CurrentToken, GetExpression, GetTerm
     Wend
End Function
'<Simple Call> ::= (SIN|COS|SQR|EXP|LOG ...)
Private Function Simple_Call(Value As Double, ByVal AFuncName As String) As Double
    Select Case AFuncName
        Case "SIN": Simple_Call = Sin(Value)
        Case "COS": Simple_Call = Cos(Value)
        Case "SQR": Simple_Call = Sqr(Value)
        Case "EXP": Simple_Call = Exp(Value)
        Case "LOG": Simple_Call = Log(Value)
        Case Else
                SynErr
     End Select
End Function
'<Const>  ::= (PI|...)
Private Function GetConstValue(Value As Double, ByVal AConstName As String) As Boolean
    GetConstValue = True
    Select Case AConstName
        Case "PI": Value = 3.14159265358979
        Case Else
             GetConstValue = False
    End Select
End Function
 
Private Sub UnairyOperation(ByVal OP As TokenType, Value As Double)
    Select Case OP
        Case tkOpMinus: Value = -Value
        Case tkOpNot: Value = Not Value
        Case tkOpPlus: Value = Value
        Case Else
                SynErr
     End Select
End Sub
 
Private Sub BinaryOperation(ByVal OP As TokenType, Value1 As Double, Value2 As Double)
    Select Case OP
        Case tkOpPlus:  Value1 = Value1 + Value2
        Case tkOpMinus:  Value1 = Value1 - Value2
        Case tkOpMul:  Value1 = Value1 * Value2
        Case tkOpDivF: Value1 = Value1 / Value2
        Case tkOpDiv:  Value1 = Value1 \ Value2
        Case tkOpMod:  Value1 = Value1 Mod Value2
        Case tkOpOr:   Value1 = Value1 Or Value2
        Case tkOpAnd:  Value1 = Value1 And Value2
        Case tkOpXor:  Value1 = Value1 Xor Value2
        Case tkOpPow:  Value1 = Value1 ^ Value2
        Case tkOpShl:  Value1 = Value1 * (2 * Value2)
        Case tkOpShr:  Value1 = Value1 \ (2 * Value2)
        Case Else
                SynErr
     End Select
End Sub
 
Public Function EvalExp(ByVal Text As String) As Double
    fLexer.Text = Text
    EvalExp = GetExpression
    SynErr CurrentToken <> tkNone
End Function
 
Private Sub SynErr(Optional ByVal ARaise As Boolean = True)
     If ARaise Then
       Err.Description = "Erreur d'évaluation à la position " & CStr(fLexer.Position)
       Err.Raise 1001
     End If
End Sub

Pour tester

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Dim D As New CExpression
   MsgBox D.EvalExp("10+20/2")

Exercice : Source d'une Calculatrice en VB6 [Sources]

Vos contributions VB6

Discussions similaires

Partager

Partager