Une petite calculatrice

Présentation
Source, sur les bases d'une calculatrice en VB6
Téléchargement
2  1 
Téléchargé 261 fois Voir les 9 commentaires
Détails
Catégories : Divers
Avatar de SfJ5Rpw8
Expert éminent sénior
Voir tous les téléchargements de l'auteur
Licence : Autre
Date de mise en ligne : 29 décembre 2010




Avatar de bidou bidou - Expert éminent https://www.developpez.com
le 11/04/2009 à 0:24
Amusons nous alors.

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

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

Avatar de ProgElecT ProgElecT - Rédacteur/Modérateur https://www.developpez.com
le 11/04/2009 à 14:02
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.
Avatar de Delbeke Delbeke - Membre expert https://www.developpez.com
le 11/04/2009 à 15:56
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.
Avatar de medkarim medkarim - Membre régulier https://www.developpez.com
le 05/05/2009 à 8:42
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é

Avatar de SfJ5Rpw8 SfJ5Rpw8 - Expert éminent sénior https://www.developpez.com
le 05/05/2009 à 21:17
merci medkarim pour ta contribution j'ai rajouté une image pour donnez des idées à d'autres contributeurs ...
Avatar de Xsat1 Xsat1 - Futur Membre du Club https://www.developpez.com
le 13/02/2010 à 17:51
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
Avatar de nathanscott nathanscott - Nouveau Candidat au Club https://www.developpez.com
le 17/08/2011 à 21:53
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.
Avatar de SfJ5Rpw8 SfJ5Rpw8 - Expert éminent sénior https://www.developpez.com
le 18/08/2011 à 0:02
Citation Envoyé par nathanscott Voir le message
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
Avatar de Montor Montor - Membre éprouvé https://www.developpez.com
le 07/09/2012 à 22:02
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
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
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
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
'&lt;Factor> ::= (+|-)&lt;Expression>| NUMBER | &lt;Simple Call> | CONSTANT |'('&lt;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 &lt;> tkOpenExp
                 Ret = Simple_Call(GetExpression, Ident)
                 SynErr CurrentToken &lt;> tkCloseExp
              End If
        Case tkOpenExp
              Ret = GetExpression
              SynErr CurrentToken &lt;> tkCloseExp
        Case tkOpenBra
              Ret = GetExpression
              SynErr CurrentToken &lt;> tkCloseBra
        Case tkNone
              Ret = 0
        Case Else
              SynErr
      End Select
      NextToken
    End If
    GetFactor = Ret
End Function
'&lt;Exp> ::= &lt;Factor>(^&lt;Factor>)*
Private Function GetExp() As Double
     GetExp = GetFactor
     While CurrentToken = tkOpPow
           BinaryOperation CurrentToken, GetExp, GetFactor
     Wend
End Function
'&lt;Term> ::= &lt;Exp> (DIV | * | / | MOD ... &lt;Exp>)*
Private Function GetTerm() As Double
     GetTerm = GetExp
     While IsFacOperator(CurrentToken)
           BinaryOperation CurrentToken, GetTerm, GetExp
     Wend
End Function
'&lt;Expression>  ::= &lt;Term> (+|- ... &lt;Term>)*
Private Function GetExpression() As Double
     GetExpression = GetTerm
     While IsTermOperator(CurrentToken)
           BinaryOperation CurrentToken, GetExpression, GetTerm
     Wend
End Function
'&lt;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
'&lt;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 &lt;> 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
1
2
Dim D As New CExpression
   MsgBox D.EvalExp("10+20/2")
Developpez.com décline toute responsabilité quant à l'utilisation des différents éléments téléchargés.
Contacter le responsable de la rubrique Visual Basic 6