Résistances

Aller en bas

Résistances

Message par Shadow272 le Sam 30 Déc - 9:03

Résistances

Ce petit programme vous donne la valeur des résistance selon leur code couleur.
Tout à la souris Smile .
Téléchargeable [Vous devez être inscrit et connecté pour voir ce lien]

Code:

CLS
DEFMOUSE 0
' --------------------------------------sauvegarde de la palette
'
pal$=""
FOR i%=0 TO 31
  pal$=pal$+CHR$(PEEK(&HFFFF8240+i%))
NEXT i%
'
xb%=XBIOS(2)
'
DIM couleur%(15)
'
' -------------------------Sauvegarde + changement r‚solution si n‚cessaire
res_ecran%=XBIOS(4)
IF res_ecran%<>0                 ! basse r‚solution
  ~XBIOS(5,L:-1,L:-1,0)
ENDIF
'
'
INLINE sp3_unpack%,1602
'
DIM reg%(16)                  ! pour initialiser les registres
DIM depack_buff%(32066)       ! On cr‚e un buffer pour les images d‚pack‚es
adr2%=V:depack_buff%(0)       ! on pointe sur ce buffer
'
INLINE resistance%,1266
ec1$=SPACE$(32000)
ec2$=ec1$
c$=SPACE$(32)
ec1%=V:ec1$
ec2%=V:ec2$
c%=V:c$
'
FOR i%=0 TO 15
  SETCOLOR i%,0,0,0
NEXT i%
'
FOR y%=0 TO 9
  READ cl%
  couleur%(y%)=cl%
  DEFFILL cl%,2,8
  PBOX 0,0+(y%*9),8,8+(y%*9)
  PBOX 10,0+(y%*9),32,8+(y%*9)
NEXT y%
FOR y%=0 TO 1
  READ cl%
  DEFFILL cl%,2,8
  PBOX 50,0+(y%*9),58,8+(y%*9)
  PBOX 60,0+(y%*9),92,8+(y%*9)
NEXT y%
BMOVE xb%,ec2%,32000
CLS
'
'
@depack(resistance%,1266)
BMOVE adr2%+2,c%,32
BMOVE adr2%+34,ec1%,32000
~XBIOS(6,L:c%,32)
BMOVE ec1%,xb%,32000
'
DEFLINE 3,3,0,0
COLOR 13
LINE 107,29,107,69
LINE 140,29,140,69
LINE 173,29,173,69
COLOR 11
LINE 210,29,210,69
'
DEFTEXT 1,0,0,6
'
hom$="0"
hom$=hom$+CHR$(234)
TEXT 40,188,hom$
TEXT 132,188,"+/- 10%"
c1%=0
c2%=0
c3%=0
c4%=11
'
DO
  MOUSE mx%,my%,mk%
  IF my%>28 AND my%<71
    '
    ' anneau 1
    '
    IF mx%>104 AND mx%<110
      @anneau(100,120,104,c1%)
      c1%=cp2%
      COLOR couleur%(c1%)
      LINE 107,29,107,69
      @affiche
    ENDIF
    '
    ' anneau 2
    '
    IF mx%>137 AND mx%<143
      @anneau(133,153,137,c2%)
      c2%=cp2%
      COLOR couleur%(c2%)
      LINE 140,29,140,69
      @affiche
    ENDIF
    '
    ' anneau 3
    '
    IF mx%>170 AND mx%<176
      @anneau3(166,186,170,c3%)
      c3%=cp2%
      COLOR couleur%(c3%)
      LINE 173,29,173,69
      @affiche
    ENDIF
    '
    ' anneau 4
    '
    IF mx%>207 AND mx%<213
      c5%=0
      IF c4%=11
        c5%=1
      ENDIF
      @anneau4(203,223,207,c5%)
      IF cp2%=0
        c4%=14
      ELSE
        c4%=11
      ENDIF
      COLOR c4%
      LINE 210,29,210,69
      @affiche
    ENDIF
    '
  ENDIF
  '
  IF mx%<315 AND mx%>209 AND my%<196 AND my%>174
    RC_COPY xb%,212,177,101,17 TO xb%,212,177,8
    DO
      MOUSE mx%,my%,mk%
      IF mk%=1
        mk%=3
      ENDIF
      EXIT IF mk%=3 OR mx%<210 OR mx%>314 OR my%<175 OR my%>195
    LOOP
    RC_COPY xb%,212,177,101,17 TO xb%,212,177,8
  ENDIF
  EXIT IF mk%=3
LOOP
'
@fin
'
DATA 13,5,2,9,6,3,4,7,10,1,14,11
'
> PROCEDURE fin
  '
  ' --------------------------------------restauration des parametres de l'ecran
  '
  CLS
  '
  IF XBIOS(4)<>res_ecran%
    VOID XBIOS(5,L:-1,L:-1,res_ecran%)
  ENDIF
  '
  '
  ~XBIOS(6,L:(V:pal$))
  '
RETURN
'
> PROCEDURE depack(origine%,taille_packee%)
  ' le fichier depack‚ est stock‚ dans adr2
  BMOVE origine%,adr2%,taille_packee%
  reg%(8)=adr2%
  RCALL sp3_unpack%,reg%()
RETURN
'
> PROCEDURE anneau(px1%,px2%,px3%,cp%)
  '
  RC_COPY ec2%,0,0,8,90 TO xb%,px3%-2,72
  '
  cp2%=cp%
  DEFFILL 0,2,8
  '
  DO
    MOUSE mx%,my%,mk%
    EXIT IF mx%<px1% OR mx%>px2% OR my%>161
    FOR i%=0 TO 9
      IF my%<81+(i%*9) AND my%>72+(i%*9) AND cp%<>i%
        PBOX px3%+7,72+(cp%*9),px3%+32,80+(cp%*9)
        cp%=i%
        RC_COPY ec2%,10,cp%*9,23,9 TO xb%,px3%+7,72+(cp%*9)
      ENDIF
    NEXT i%
    EXIT IF mk%=1
  LOOP
  '
  '
  PBOX px3%-2,72,px3%+33,162
  '
  IF mk%=1
    cp2%=cp%
  ENDIF
  '
RETURN
> PROCEDURE anneau3(px1%,px2%,px3%,cp%)
  '
  RC_COPY ec2%,0,0,8,72 TO xb%,px3%-2,72
  '
  cp2%=cp%
  DEFFILL 0,2,8
  '
  DO
    MOUSE mx%,my%,mk%
    EXIT IF mx%<px1% OR mx%>px2% OR my%>161
    FOR i%=0 TO 7
      IF my%<81+(i%*9) AND my%>72+(i%*9) AND cp%<>i%
        PBOX px3%+9,72+(cp%*9),px3%+32,80+(cp%*9)
        cp%=i%
        RC_COPY ec2%,10,cp%*9,23,9 TO xb%,px3%+9,72+(cp%*9)
      ENDIF
    NEXT i%
    EXIT IF mk%=1
  LOOP
  '
  '
  PBOX px3%-2,72,px3%+32,162
  '
  IF mk%=1
    cp2%=cp%
  ENDIF
  '
RETURN
> PROCEDURE anneau4(px1%,px2%,px3%,cp%)
  '
  RC_COPY ec2%,50,0,8,18 TO xb%,px3%-2,75
  '
  cp2%=cp%
  DEFFILL 0,2,8
  '
  DO
    MOUSE mx%,my%,mk%
    EXIT IF mx%<px1% OR mx%>px2% OR my%>161
    FOR i%=0 TO 1
      IF my%<84+(i%*9) AND my%>75+(i%*9) AND cp%<>i%
        PBOX px3%+8,72+(cp%*9),px3%+32,83+(cp%*9)
        cp%=i%
        RC_COPY ec2%,60,cp%*9,23,9 TO xb%,px3%+8,75+(cp%*9)
      ENDIF
    NEXT i%
    EXIT IF mk%=1
  LOOP
  '
  '
  PBOX px3%-2,72,px3%+32,162
  '
  IF mk%=1
    cp2%=cp%
  ENDIF
  '
RETURN
'
> PROCEDURE affiche
  hom%=(c1%*10)
  ADD hom%,c2%
  hom$=hom$+STR$(c2%)
  IF c3%=1 OR c3%=4 OR c3%=7
    MUL hom%,10
  ENDIF
  IF c3%=2 OR c3%=5
    MUL hom%,100
  ENDIF
  hom$=STR$(hom%)
  IF c3%>2 AND c3%<6
    hom$=hom$+"K"
  ENDIF
  IF c3%>5
    hom$=hom$+"M"
  ENDIF
  hom$=hom$+CHR$(234)
  hom$=hom$+"  "
  TEXT 40,188,hom$
  IF c4%=11
    TEXT 132,188,"+/- 10%"
  ELSE
    TEXT 132,188,"+/- 5% "
  ENDIF
RETURN
avatar
Shadow272
Admin

Messages : 137
Date d'inscription : 28/12/2017
Age : 60
Localisation : Hainaut Belgique

Voir le profil de l'utilisateur http://toutatari.blog4ever.xyz/

Revenir en haut Aller en bas

Revenir en haut


 
Permission de ce forum:
Vous ne pouvez pas répondre aux sujets dans ce forum