Bonjour à tous,(J'aimerais transporter ce programme dans la section "Suprême de code")
J'ai fait un programme génial qui permet de décomposer un nombre en produit de facteurs premiers et je vous le présente.
J'ai "traduit" pour cela un code qui figurait dans le mode d'emploi d'une calculatrice scientifique, la CASIO fx-8500G, en lui ajoutant quelques perfectionnements:
Code : Tout sélectionner
REM *** Ce programme est inspiré sur celui de la calculatrice fx-8500G
Option Explicit
Option Base 1
Dim Entry as Double
Dim Verify as Double
Dim Factor as Long
Dim Result (0) As String
Dim FilterValue As String
Dim AntNumb As String
Dim PosFirstChar as Integer
Dim MsgString As String
Dim EWC As Long
Dim NVFA As Long
Dim CountNumb As Integer
Dim ActStr as String
Dim AllStr As String
Dim ActPos As Integer
Dim DefNbr as Long
Dim DefNbr2 as Long
Dim Pos as Long
Dim AntPos as Long
Const Msg as String = "Analyse de facteurs premiers"
Sub Start
Defnbr = 1
FilterValue = inputBox ("Veuillez entrer un nombre afin de le décomposer en produit de facteurs premiers (pas de 0 ni de 1, ni de nombres trop grands !)" & _
chr$(13) & "Attention ! Si votre nombre est grand, l'opération peut prendre du temps.", Msg, AntNumb)
Entry = FilterValue
EWC = Entry
If FilterValue = ""then stop
If entry = "1" or entry = "0" then call OnError
'If msgBox ("Les nombres vont être affichés un par un.", 1, Msg) = 2 then Stop
wait 5
call Step2
End Sub
Sub OnError
If msgBox ("Votre numéro ne doit pas être 0 ou 1. Veuillez en changer.", 48, Msg) = 1 then call Start else stop
end Sub
Sub Step1
'If msgBox (2, 1, Msg) = 2 then Stop
Incluse (2)
Entry = entry/2
If entry = 1 then call step9
Call Step2
End Sub
Sub Step2
If Entry/2 = Fix (Entry/2) then call step1 else Factor = 3
Call Step3
End Sub
Sub Step3
Verify = Sqr (entry) + 1
Call Step4
End Sub
Sub Step4
If Factor >= Verify then call Step8
If Entry/Factor = Fix (entry/factor) then call step6
Call Step5
End Sub
Sub Step5
Factor = factor + 2
Call step4
End Sub
Sub Step6
If (Entry/Factor*factor-entry) = 0 then call step7 else call step5
End Sub
Sub Step7
'If msgBox (factor, 1, Msg) = 2 then Stop
Incluse (factor)
Entry = entry/factor
Call step3
End Sub
Sub Step8
'If msgBox (entry, 1, Msg) = 2 then Stop
Incluse (entry)
Call Step9
End Sub
Sub Step9
MsgString = "Solution: " & chr$(13) & EWC & " = " & join (Result, " x ") & " " & Chr$(13) & chr$(13) & _
"Désirez-vous recommencer avec un autre nombre ? "
PosFirstChar = inStr (MsgString, " x ")
Mid (MsgString, PosFirstChar, 3, "")
call ExpCh
If result (UBound (result)) = EWC then msgString = "Solution: " & chr$(13) & "Votre nombre était déjà premier." & Chr$(13) & chr$(13) & _
"Désirez-vous recommencer avec un autre nombre ? "
'If msgBox ("L'opération et finie. Voulez-vous recommencer avec un autre nombre ?", 4+32+256, Msg) = 6 then
If msgBox (MsgString, 4+256, msg) = 6 then
ReDim result (0) : AntPos = 0 : Pos = 0 : DefNbr = 0 : DefNbr2 = 0 : msgstring = "" : AntNumb = EWC : EWC = 0 : CountNumb = 0 : ActPos = 0 : ActStr = "" : AllStr = ""
call Start
else
msgBox ("Alors, au revoir !", 0, Msg)
Stop
EndIf
End Sub
Sub Incluse (ActFactor As Long)
NVFA = UBound (result)
ReDim Preserve Result (NVFA)
Result (UBound (Result)) = ActFactor
End Sub
Function ConvertToExposantValue (Number As Long)
AllStr = ""
For CountNumb = 1 to Len (number)
ActPos = Mid (CStr (number), countNumb, 1)
If ActPos = 0 then
ActStr = "⁰"
else
ActStr = choose (actPos, "¹", "²", "³", "⁴", "⁵", "⁶", "⁷", "⁸", "⁹")
endIf
AllStr = AllStr & ActStr
Next
ConvertToExposantValue() = AllStr
End Function
Sub ExpCh()
Do until defNbr = entry + 1
defNbr = defNbr + 1
AntPos = 14 + Len (EWC)
Do until defNbr2 = EWC - 1
If InStr (antPos, MsgString, " " & DefNbr & " ") then
If defNbr2 = 0 then Pos = InStr (antPos, MsgString, DefNbr)
AntPos = inStr (antPos, msgString, DefNbr) + 1
DefNbr2 = defNbr2 + 1
else
Exit Do
End If
Loop
If inStr (msgString, defNbr) and defnbr2 > 1 then
Mid (MsgString, Pos, len (defNbr)*defnbr2 + 3*(defNbr2 - 1), defNbr & convertToExposantValue (defNbr2)) : EndIf
DefNbr2 = 0
Loop
End SubJ'espère que mon programme servira !
Au revoir !
