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
| Option Explicit
Dim ElementS() As Single
Dim NbrElem() As Integer, NumEl As Integer
Dim LongueurT As Single
Private Sub Form_Load()
'placement des différents contrôles et valeur par défaut
Label1.Move 60, 60, 480, 195: Label1.Caption = "Cotè A"
Text1.Move 660, 0, 1155, 315: Text1.Text = "8"
Label2.Move 2160, 60, 480, 195: Label2.Caption = "Cotè B"
Text2.Move 2760, 0, 1155, 315: Text2.Text = "6"
Label3.Move 60, 420, 390, 195: Label3.Caption = "Elem."
Text3.Move 660, 420, 1155, 315: Text3.Text = "0,5"
Command2.Move 1860, 420, 795, 315: Command2.Caption = "Ajout. -->"
Command3.Move 1860, 780, 795, 315: Command3.Caption = "supp. <--"
Command4.Move 120, 1440, 1875, 315: Command4.Caption = "Calcul suivant périmètre"
Command5.Move 2040, 1440, 1935, 315: Command5.Caption = "Calcul suivant les cotés"
List1.Move 2700, 420, 1215, 840
List1.Clear: List1.AddItem "3": List1.AddItem "2": List1.AddItem "1": List1.AddItem "0,5"
Label4.Move 120, 1980, 3855, 2115: Label4.Caption = "": Label4.BackColor = &HFFFFFF
Me.Height = 4770: Me.Width = 4320
End Sub
Private Function VerifNumerci(AsciiCode As Integer) As Integer
VerifNumerci = AsciiCode
Select Case AsciiCode
Case 8, 44 'autorisation de la touche suppr et la virgule
Case 46: VerifNumerci = 44 'pour VB6 il lui faut une ,(virgule) pour les calcul décimaux
Case 48 To 57 'autorisation de toutes les touches numériques (0 à 9)
'sinon annule la dernière touche
Case Else: VerifNumerci = 0
End Select
End Function
Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = VerifNumerci(KeyAscii)
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
KeyAscii = VerifNumerci(KeyAscii)
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
KeyAscii = VerifNumerci(KeyAscii)
End Sub
Private Sub Command2_Click()
List1.AddItem CSng(Text3.Text)
End Sub
Private Sub Command3_Click()
If List1.ListCount >= 1 Then List1.RemoveItem (List1.ListCount - 1)
End Sub
Private Sub Command4_Click()
Dim MsG As String, T As Integer
Dim CoteA As Single, CoteB As Single, PerimetrE As Single
ReDim ElementS(List1.ListCount - 1)
For T = 0 To List1.ListCount - 1
ElementS(T) = List1.List(T)
Next T
ReDim NbrElem(UBound(ElementS))
CoteA = CSng(Text1.Text): CoteB = CSng(Text2.Text)
Label4.Caption = ""
'--------------------- Calcul suivant périmètre --------------------------------------------
PerimetrE = (CoteA + CoteB) * 2
LongueurT = PerimetrE: NumEl = 0
While LongueurT >= ElementS(UBound(ElementS))
While NumEl <= UBound(ElementS)
Analyse NumEl
Wend
DoEvents
Wend
'-------------------- fin Calcul suivant périmètre ------------------------------------------
'************************* pour la demo, création d'un message ******************************
MsG = "pour un périmètre de " & PerimetrE & " il faut" & vbCrLf
For T = 0 To UBound(ElementS)
If NbrElem(T) <> 0 Then MsG = MsG & NbrElem(T) & " élément(s) de " & ElementS(T) & vbCrLf
Next T
If LongueurT <> 0 Then
MsG = MsG & "plus 1 élément de " & ElementS(UBound(ElementS)) & "pour les " & LongueurT & " restant"
End If
'********************************************************************************************
'affichage des informations calculées
Label4.Caption = MsG
End Sub
Private Sub Analyse(NumElem)
If LongueurT - ElementS(NumElem) >= 0 Then
NbrElem(NumElem) = NbrElem(NumElem) + 1
LongueurT = LongueurT - ElementS(NumElem)
Else
NumEl = NumElem + 1
End If
End Sub
'------------------ Calcul suivant les cotés A et B -----------------------------------------
Private Sub Command5_Click()
Dim MsG As String, T As Integer
Dim CoteA As Single, CoteB As Single, PerimetrE As Single
ReDim ElementS(List1.ListCount - 1)
For T = 0 To List1.ListCount - 1
ElementS(T) = List1.List(T)
Next T
ReDim NbrElem(UBound(ElementS))
CoteA = CSng(Text1.Text): CoteB = CSng(Text2.Text)
Label4.Caption = ""
'------------------ Calcul suivant le coté A ------------------------------------------------
LongueurT = CoteA: NumEl = 0
'bouclage pour coté A
While LongueurT >= ElementS(UBound(ElementS))
While NumEl <= UBound(ElementS)
Analyse NumEl
Wend
DoEvents
Wend
'------------------ fin Calcul suivant le cotés A -------------------------------------------
'************************* pour la demo, création d'un message ******************************
MsG = "pour 1 coté A " & CoteA & " il faut" & vbCrLf
For T = 0 To UBound(ElementS)
If NbrElem(T) <> 0 Then MsG = MsG & NbrElem(T) & " élément(s) de " & ElementS(T) & vbCrLf
Next T
If LongueurT <> 0 Then
MsG = MsG & "plus 1 élément de " & ElementS(UBound(ElementS)) & "pour les " & LongueurT & " restant"
End If
MsG = MsG & vbCrLf & "pour 1 coté B " & CoteB & " il faut" & vbCrLf
'********************************************************************************************
'------------------ Calcul suivant le coté B ------------------------------------------------
ReDim NbrElem(UBound(ElementS)) 'pour remetre à zero
LongueurT = CoteB: NumEl = 0
'bouclage pour coté B
While LongueurT >= ElementS(UBound(ElementS))
While NumEl <= UBound(ElementS)
Analyse NumEl
Wend
DoEvents
Wend
'------------------ fin Calcul suivant le coté B --------------------------------------------
'************************* pour la demo, création d'un message ******************************
For T = 0 To UBound(ElementS)
If NbrElem(T) <> 0 Then MsG = MsG & NbrElem(T) & " élément(s) de " & ElementS(T) & vbCrLf
Next T
If LongueurT <> 0 Then
MsG = MsG & "plus 1 élément de " & ElementS(UBound(ElementS)) & "pour les " & LongueurT & " restant"
End If
'********************************************************************************************
Label4.Caption = MsG
End Sub |
Partager