QuickBasic Cafe Forum

Posted: **Tue Nov 10, 2009 7:32 am**

Okay, So I am writing a program that gives a persons exact age in days and years, and everything thing is going great except the leap years, every 4 years there is an extra day, and so what I need help with is getting it add a day for every 4 years off of the original birthday year for the leap years.

Posted: **Sun Nov 22, 2009 3:52 am**

Every 4 years is true when it is NOT a Century leap year. Century leap years occur every 400 years. Example is that 1900 was not a leap year, but is divisible by 4. 2000 was a leap year because it was divisible by 400.

First you need to see if the birthdate is before February 29, if it was a leap year, Then add a day if it was. Then you have to add another day testing the leap years after that year. If it is a leap year, then add another day.

Use MOD (remainder division) to calculate the leap years:

Code: Select all

leapyear = 0
IF year MOD 100 = 0 THEN  ' a century change only
    IF year MOD 400 = 0 Then leapyear = -1 
ELSE : IF year MOD 4 = 0 THEN leapyear = -1
END IF

You can just check every 4 years counting upwards to the present date after you find the first leapyear of the person's life.

Posted: **Thu Mar 10, 2016 1:46 am**

There is a simple way to calculate the number of days between two dates:
Equations are to calculate the number of days Julian and day of the week (0 to 6), where 0 = Sunday and 6 = Saturday.
The algorithm is shown in the flowchart below.
The "CCAL" subroutine executes the equations.
NDJ = number of days Julian
DW = day of the week (0 to 6)
With a little creativity we can get other data.

Code: Select all

CLS
DW$(0) = "Sunday"
DW$(1) = "Monday"
DW$(2) = "Tuesday"
DW$(3) = "Wednesday"
DW$(4) = "Thursday"
DW$(5) = "Friday"
DW$(6) = "Saturday"
X = 0
'----------------------
YEAR = 2015  'Not leap years
MONTH = 1
DAY = 1
PRINT MONTH; "-"; DAY; "-"; YEAR;
GOSUB CCAL
PRINT DW$(DW)
X = NDJ
'----------------------
YEAR = 2016 'leap years
MONTH = 1
DAY = 1
PRINT MONTH; "-"; DAY; "-"; YEAR;
GOSUB CCAL
PRINT DW$(DW)
PRINT "This period has"; NDJ - X; "days "
X = NDJ
'----------------------
YEAR = 2017
MONTH = 1
DAY = 1
PRINT MONTH; "-"; DAY; "-"; YEAR;
GOSUB CCAL
PRINT DW$(DW)
PRINT "This period has"; NDJ - X; "days"
X = NDJ
'----------------------
YEAR = 2017
MONTH = 3
DAY = 10
PRINT MONTH; "-"; DAY; "-"; YEAR;
GOSUB CCAL
PRINT DW$(DW)
PRINT "This period has"; NDJ - X; "days"
'----------------------
END
END
'----------------------
CCAL: 'Calculating the amount of Julian days and the day of the week (0~6)
IF MONTH > 2 THEN
  MONTH = MONTH + 1
ELSE
  YEAR = YEAR - 1
  MONTH = MONTH + 13
END IF
NDJ = INT(365.25 * YEAR) + INT(30.6001 * MONTH) + DAY
DW = (NDJ + 5) / 7
DW = DW - INT(DW)
DW = INT(.1 + 7 * DW)
RETURN

Posted: **Thu Mar 10, 2016 3:38 pm**

Having the above information, I could develop this Quickbasic program.
It is in the format and language of my native country, but with a bit of calm can be formatted to any country.
To compile in order to turn into an executable, you must call the Quick-Basic including the library: QBX/L

Code: Select all

'---------------------------------Calendas------------------------------------
DECLARE SUB ENTRADA (L1%, C1%, LNH%, CRT$, X$, CJ$)
DECLARE SUB PSMT (LSP%, LIP%, CLP%, CRP, PLP%, TAP%)
DECLARE SUB CLICK (CRT$)
DECLARE SUB MOUSE (K%, L%, C%)
DECLARE SUB CAL (DIA, MES, ANO, CDF, DSP, DDS, QDM, QMD, DIA$, DIAS$, NDJ)
DECLARE FUNCTION FMT$ (F1%, F2%, F3%, F4%, FI$)
DECLARE SUB JANELA (L1, C1, L2, C2, COR, MSG$, RDP$)
DECLARE SUB CopyTela (I%, L1%, C1%, L2%, C2%, TL$)
DECLARE SUB IMPRIMIR (NA$)
ON ERROR GOTO ENCERRA

A$ = COMMAND$: B1% = ABS(VAL(A$) > 0)
I% = INSTR(A$, ",") + 1: L1% = VAL(MID$(A$, I%, 2))
I% = INSTR(I%, A$, ",") + 1: C1% = VAL(MID$(A$, I%, 2))
I% = INSTR(I%, A$, ",") + 1: B2% = ABS(VAL(MID$(A$, I%, 2)) > 0)
IF L1% = 0 THEN L1% = 7
IF C1% = 0 THEN C1% = 16
TYPE RegType
  AX AS INTEGER: BX AS INTEGER: CX AS INTEGER: DX AS INTEGER
  BP AS INTEGER: SI AS INTEGER: DI AS INTEGER: FG AS INTEGER
END TYPE: DIM PL%(1), PC%(1)

INICIO:
IF L1% < 1 THEN L1% = 1 ELSE IF L1% > 12 THEN L1% = 12
IF C1% < 1 THEN C1% = 1 ELSE IF C1% > 31 THEN C1% = 31
IF ABS(B2%) > 0 THEN
  B2% = SGN(7 - L1%): IF B2% = 0 THEN B2% = 1
  B3% = SGN(15 - C1%): IF B3% = 0 THEN B3% = 1
END IF: COR = 15.5
IF ABS(B2%) > 0 THEN
  IF B2% < 0 THEN
    IF B3% < 0 THEN COR = COR + .04 ELSE COR = COR + .01
  ELSE
    IF B3% < 0 THEN COR = COR + .03 ELSE COR = COR + .02
  END IF
END IF: L2% = L1% + 14: C2% = C1% + 52
CALL CopyTela(0, L1% + B2% * ABS(B2% < 0), C1% + 2 * B3% * ABS(B3% < 0), L2% + B2% * ABS(B2% > 0), C2% + 2 * ABS(B3% > 0), TL$)
CALL JANELA((L1%), (C1%), L1% + 13, C1% + 50, COR, "Calendario-Perpetuo", "")
LOCATE L1% + 10, C1%: PRINT CHR$(195); STRING$(49, 196); CHR$(180)
LOCATE L1% + 11, C1% + 1: COLOR 3: PRINT "<ESC>Sai <F6>Imprime <TAB>Mes/Ano   Hora:";
LOCATE L1% + 12, C1% + 1: PRINT "<HOME> <PgUp> <PgDw> <END>     <ENTER>"; MID$("Assume_DataSai", 11 * ABS(B1% = 0) + 1, 11);
DT1$ = MID$(DATE$, 4, 3) + LEFT$(DATE$, 3) + RIGHT$(DATE$, 4): DT2$ = DT1$: QD = 0
JS = 5: MES$ = "Janeiro  FevereiroMarco    Abril    Maio     Junho    Julho    Agosto   Setembro Outubro  Novembro Dezembro "
DIAS$ = "Do.Se.Te.Qu.Qu.Se.Sa."
PL%(0) = VAL(LEFT$(DATE$, 2)): PC%(0) = PL%(0): PL%(1) = VAL(RIGHT$(DATE$, 4)): PC%(1) = PL%(1): UT% = 1: A$ = "K": X$ = MKI$(0) + MKI$(0) + MKI$(0)
DO
  IF A$ = CHR$(9) THEN A$ = "K"
  IF INSTR(" KM", A$) > 1 THEN UT% = ABS(UT% = 0): CALL JANELA(L1% + 1, C1% + 1, L1% + 7, C1% + 14, .6, "Mes", ""): CALL JANELA(L1% + 1, C1% + 15, L1% + 7, C1% + 20, .6, "Ano", "")
  '-----Imprime o Mes-----
  IF PL%(0) < 1 THEN PL%(0) = 1 ELSE IF PL%(0) > 12 THEN PL%(0) = 12
  IF PC%(0) < 1 THEN PC%(0) = 1 ELSE IF PC%(0) > 5 THEN PC%(0) = 5
  CL% = PL%(0) - PC%(0) + 1: COLOR 8 + 7 * (UT% = 0)
  FOR I% = 1 TO 5: LOCATE I% + L1% + 1, C1% + 2: COLOR , 6 + ABS(I% = PC%(0)): PRINT USING "##"; CL%; : PRINT CHR$(179); : PRINT MID$(MES$, CL% * 9 - 8, 9); : CL% = CL% + 1: NEXT
  '-----Imprime o Ano-----
  IF PL%(1) < 1 THEN PL%(1) = 1 ELSE IF PL%(1) > 9999 THEN PL%(1) = 9999
  IF PC%(1) < 1 THEN PC%(1) = 1 ELSE IF PC%(1) > 5 THEN PC%(1) = 5
  CL% = PL%(1) - PC%(1) + 1: COLOR 8 + 7 * (UT% = 1)
  FOR I% = 1 TO 5: LOCATE I% + L1% + 1, C1% + 16: COLOR , 6 + ABS(I% = PC%(1)): PRINT USING "####"; CL%; : CL% = CL% + 1: NEXT
  '-----Imprime o Posometro------
  PL% = PL%(UT%): LNH% = PC%(UT%): QL% = 12 + UT% * 9987: CALL PSMT(L1% + 2, L1% + 6, C1% + 20 + 6 * (UT% = 0), .6, PL%, QL%)
  '-----Imprime o Calend rio-----
  DIA = 1: MES = PL%(0): ANO = PL%(1): CALL CAL(DIA, MES, ANO, CDF, DSP, DDS, QDM, QMD, DIA$, DIAS$, NDJ)
  CALL JANELA(L1% + 1, C1% + 21, L1% + 9, C1% + 49, 1.7, RTRIM$(MID$(MES$, PL%(0) * 9 - 8, 9)) + "/" + LTRIM$(STR$(PL%(1))), "")
  X% = L1% + 3: Y% = DDS: FOR I% = 1 TO 7: LOCATE L1% + 2, C1% + 18 + I% * 4: COLOR 4 * ABS(I% = 1) + (8 * ABS(I% - 1.5 > JS)), 7: PRINT MID$(DIAS$, I% * 3 - 2, 3); : NEXT
  FOR I% = 1 TO QDM
    LOCATE X%, Y% * 4 + C1% + 23: IF Y% = 0 THEN COLOR 4, 7 ELSE COLOR 8 * ABS(Y% - .5 > JS), 7
    IF I% = VAL(MID$(DATE$, 4, 2)) THEN IF MES = VAL(LEFT$(DATE$, 2)) AND ANO = VAL(RIGHT$(DATE$, 4)) THEN COLOR , 2
    IF I% = VAL(LEFT$(DT1$, 2)) AND VAL(MID$(DT1$, 4, 2)) = PL%(0) AND VAL(RIGHT$(DT1$, 4)) = PL%(1) THEN COLOR 1
    IF I% = VAL(LEFT$(DT2$, 2)) AND VAL(MID$(DT2$, 4, 2)) = PL%(0) AND VAL(RIGHT$(DT2$, 4)) = PL%(1) THEN COLOR 1
    PRINT USING "##"; I%; : Y% = Y% + 1: IF Y% > 6 THEN Y% = 0: X% = X% + 1
  NEXT: COLOR 7, 5: LOCATE L1% + 8, C1% + 1: PRINT DT1$; CHR$(194); CHR$(16); USING "**#####"; ABS(QD); : PRINT CHR$(191); : LOCATE L1% + 9, C1% + 1: COLOR 7 + 8 * B1%: PRINT DT2$; : COLOR 7: PRINT CHR$(217); " (Dias)"; CHR$(17); CHR$(217);
  '-----Entra com Teclado ou Klick-----
  IF UT% = 1 THEN
    CJ$ = FMT$(L1% + 1, C1% + 15, L1% + 7, C1% + 20, " ") + FMT$(L1% + 1, C1% + 1, L1% + 7, C1% + 14, "K")
  ELSE
    CJ$ = FMT$(L1% + 1, C1% + 1, L1% + 7, C1% + 14, " ") + FMT$(L1% + 1, C1% + 15, L1% + 7, C1% + 20, "M")
  END IF: CJ$ = CJ$ + FMT$(L1% + 3, C1% + 23, L1% + 8, C1% + 48, ""): LNH% = LNH% + L1% + 1
  CALL ENTRADA(L1%, C1%, LNH%, CRT$, X$, CJ$): A$ = RIGHT$(CRT$, 1)
  IF A$ = CHR$(27) OR A$ = CHR$(13) THEN EXIT DO ELSE X% = CVI(MID$(X$, 3, 2)): Y% = CVI(MID$(X$, 5, 2))
  IF CVI(X$) = 1 AND (X% < L1% OR Y% < C1% OR X% > L2% - 1 OR Y% > C2% - 2) THEN
    CALL CopyTela(1, L1% + B2% * ABS(B2% < 0), C1% + 2 * B3% * ABS(B3% < 0), L2% + B2% * ABS(B2% > 0), C2% + 2 * ABS(B3% > 0), TL$)
    IF X% < L1% THEN L1% = X% ELSE IF X% > L2% - 1 THEN L1% = X% - 13
    IF Y% < C1% THEN C1% = Y% ELSE IF Y% > C2% - 2 THEN C1% = Y% - 50
    GOTO INICIO
  END IF
  IF A$ = "" AND SCREEN(X%, Y%) > 47 AND SCREEN(X%, Y%) < 58 THEN
    I% = VAL(CHR$(SCREEN(X%, Y% - 1)) + CHR$(SCREEN(X%, Y%)) + CHR$(SCREEN(X%, Y% + 1)))
    IF I% > 0 THEN
      DT1$ = DT2$: DT2$ = RIGHT$("0" + LTRIM$(STR$(I%)), 2) + "-" + RIGHT$("0" + LTRIM$(STR$(PL%(0))), 2) + "-" + RIGHT$("000" + LTRIM$(STR$(PL%(1))), 4)
      DIA = I%: MES = PL%(0): ANO = PL%(1): CALL CAL(DIA, MES, ANO, CDF, DSP, DDS, QDM, QMD, DIA$, DIAS$, NDJ): QD = NDJ
      DIA = VAL(LEFT$(DT1$, 2)): MES = VAL(MID$(DT1$, 4, 2)): ANO = VAL(RIGHT$(DT1$, 4))
      CALL CAL(DIA, MES, ANO, CDF, DSP, DDS, QDM, QMD, DIA$, DIAS$, NDJ): QD = QD - NDJ
    END IF
  END IF
  IF INSTR("@HPIQGO", A$) OR A$ > "Í" THEN
    IF A$ = "@" THEN
      DATA$ = "CALENDAS.TXT": IF DIR$(DATA$) <> "" THEN KILL DATA$
      BP% = FREEFILE: OPEN DATA$ FOR OUTPUT AS #BP%
      FOR I% = L1% + 1 TO L1% + 9: FOR X% = C1% + 21 TO C1% + 49
        PRINT #BP%, CHR$(SCREEN(I%, X%));
      NEXT: PRINT #BP%, : NEXT: CLOSE #BP%
      LOCATE L1% + 11, C1% + 42: COLOR 5, 5: CALL IMPRIMIR(DATA$)
    END IF
    IF A$ > "Í" THEN X% = ASC(A$) - 230 ELSE X% = INSTR(" HPIQGO", A$): IF X% > 1 THEN X% = VAL(MID$("-0001+0001-0004+0004-9999+9999", INSTR("HPIQGO", A$) * 5 - 4, 5)) ELSE X% = 0
    PL%(UT%) = PL%(UT%) + X%: PC%(UT%) = PC%(UT%) + X%
  END IF
LOOP: DATA$ = LEFT$(LEFT$(DT2$, 2) + "-" + MID$(DT2$, 4, 2) + "-" + RIGHT$(DT2$, 4), 10 * B1% * ABS(A$ = CHR$(13)))
BP% = FREEFILE: OPEN "CALENDAS.TXT" FOR OUTPUT AS #BP%: PRINT #BP%, DATA$: CLOSE BP%

ENCERRA:
CALL CopyTela(1, L1% + B2% * ABS(B2% < 0), C1% + 2 * B3% * ABS(B3% < 0), L2% + B2% * ABS(B2% > 0), C2% + 2 * ABS(B3% > 0), TL$): END

DATA 199,000,252,000,233,000,226,000,228,000,224,000,229,000,231,000
DATA 234,000,235,000,232,000,239,000,238,000,236,000,196,000,197,000
DATA 201,000,230,000,198,000,244,000,246,000,242,000,251,000,249,000
DATA 255,000,214,000,220,000,248,000,163,000,216,000,215,000,146,001
DATA 225,000,237,000,243,000,250,000,241,000,209,000,170,000,186,000
DATA 191,000,174,000,172,000,189,000,188,000,161,000,171,000,187,000
DATA 145,037,146,037,147,037,002,037,036,037,193,000,194,000,192,000
DATA 169,000,099,037,081,037,087,037,093,037,162,000,165,000,016,037
DATA 020,037,052,037,044,037,028,037,000,037,060,037,227,000,195,000
DATA 090,037,084,037,105,037,102,037,096,037,080,037,108,037,164,000
DATA 240,000,208,000,202,000,203,000,200,000,049,001,205,000,206,000
DATA 207,000,024,037,012,037,136,037,132,037,166,000,204,000,128,037
DATA 211,000,223,000,212,000,210,000,245,000,213,000,181,000,181,000
DATA 222,000,218,000,219,000,217,000,253,000,221,000,175,000,180,000
DATA 173,000,177,000,023,032,190,000,182,000,167,000,247,000,184,000
DATA 176,000,168,000,183,000,185,000,179,000,178,000,160,037,160,000
SUB CAL (DIA, MES, ANO, CDF, DSP, DDS, QDM, QMD, DIA$, DIAS$, NDJ)
GOSUB CQDMS: IF CDF > 0 THEN GOSUB CCDF: CDF = 0
DA = ANO: DM = MES: DD = DIA: GOSUB CCAL: DIA$ = MID$(DIAS$, DDS * 3 + 1, 3)
EXIT SUB
CQDMS: 'Calcula quant.de dias do mes e quant.do mesmo dia da semana
DA = ANO: DM = MES: DD = 1: GOSUB CCAL: QDM = NDJ
DA = ANO: DM = MES + 1: IF DM > 12 THEN DM = 1: DA = DA + 1
GOSUB CCAL: QDM = NDJ - QDM
FOR CLD = 1 TO 7
  DA = ANO: DM = MES: DD = CLD: GOSUB CCAL: IF DDS = DSP THEN EXIT FOR
NEXT: QMD = INT((QDM - CLD) / 7) + 1: RETURN
CCDF: 'Calcula a Data_Futura
FOR CLDF = 1 TO CDF
 DIA = DIA + 1
 IF DIA > QDM THEN
   DIA = 1: MES = MES + 1
   IF MES > 12 THEN MES = 1: ANO = ANO + 1: IF ANO > 99 THEN ANO = 0
   GOSUB CQDMS
 END IF
NEXT: RETURN
CCAL: 'Calcula o numero de dias juliano e dia da semana
IF DM > 2 THEN DM = DM + 1 ELSE DA = DA - 1: DM = DM + 13
NDJ = INT(365.25 * DA) + INT(30.6001 * DM) + DD: DDS = (NDJ + 5) / 7
DDS = DDS - INT(DDS): DDS = INT(.1 + 7 * DDS): RETURN
'-------Devem chegar nesta rotina as seguintes variaveis:
'  DIA (Dia da data em questao. Nao inferior a 1 nem superior ao ultimo
'       dia do mˆs; para saber a qt. de dias no mes chame esta rotina com
'       o dia "1" e receba a vari vel "QDM" como resposta)
'  MES (Mˆs da data em questao. Nao inferior a 1 nem superior 12)
'  ANO (Ano da data em questao. Todos os d¡gitos do ano; 1~9999.)
' *CDF (Prazo em dias para calculo da data futura)
'      A data futura serah devolvida nas variaveis: DIA,MES,ANO
'      O CDF serah devolvido sempre com o valor ZERO(0)
' *DSP (Dia da semana procurado. Deve ser um valor entre 0 e 6 inclusivos)
'      Os valores sao: 0=Domingo... 6=S bado
'      Com este valor serah calculado a quantidade de mesmos dias da semana
'      que o mˆs possue
'Obs.: As variaveis asteriscadas sao opcionais
'-------Serao devolvidas as seguintes variaveis:
'  DIA,MES,ANO (Os mesmos valores se o CDF for ZERO ou com a data futura se o
'               CDF for maior que ZERO)
'  NDJ (Numero de Dias Juliano)
'  DDS (Dia da semana. 0=Domingo... 6=Sabado)
'  QDM (Quantidade de dias que o mˆs tem)
'  QMD (Quantidade de mesmo-dia-da-semana que o mˆs tem)
'  DIA$ (Dia da semana escrito em portugues)
'-------Variaveis utilizadas:
'  DIA,MES,ANO,CDF,CCDF,DD,DM,DA,QDM,NDJ,CLD,CLDF,DDS,DSP,QMD,DIA$
'-------Etiquetas usadas:
'  CAL:,CCAL:,CQDMS:,CCDF:
'-------Obs.:
'  Esta rotina estah preparada para cruzar o SECULO mas o ano deve
'  chegar com todas as casas do ano em quest„o.
'----------------------------------------------
END SUB
SUB CLICK (CRT$)
DIM M%(7): FOR I% = 0 TO 3: M%(I%) = CVI(MID$(CRT$, I% * 2 + 1, 2)): NEXT
FOR I% = 18 TO LEN(CRT$) STEP 9 'Verifica Click em Outros_Retƒgulos
  IF M%(1) >= VAL(MID$(CRT$, I%, 2)) AND M%(2) >= VAL(MID$(CRT$, I% + 2, 2)) AND M%(1) <= VAL(MID$(CRT$, I% + 4, 2)) AND M%(2) <= VAL(MID$(CRT$, I% + 6, 2)) THEN
    CRT$ = MID$(CRT$, I% + 8, 1): CRT$ = LTRIM$(MID$(CHR$(0) + " ", INSTR(CHR$(9) + CHR$(13) + CHR$(27), CRT$) + 1, 1)) + CRT$: EXIT SUB
  END IF
NEXT
IF LEN(CRT$) > 9 THEN FOR I% = 4 TO 7: M%(I%) = VAL(MID$(CRT$, I% * 2 + 1, 2)): NEXT: X = INSTR(CHR$(24) + CHR$(25) + CHR$(176) + CHR$(27) + CHR$(26), CHR$(SCREEN(M%(1), M%(2))))
IF X > 0 THEN 'Se for Setas ou Mudan‡a_de_P gina
  IF M%(1) >= M%(4) AND M%(1) <= M%(6) AND M%(2) >= M%(5) AND M%(2) <= M%(7) THEN
    CRT$ = RTRIM$(" " + MID$("HP KM", X, 1)) 'Devolve a Letra da Seta
    IF X = 3 THEN I% = M%(4): DO: I% = I% + 1: LOOP UNTIL I% = M%(6) OR SCREEN(I%, M%(2)) = 2: IF I% < M%(6) THEN CRT$ = " " + MID$("IQ", (I% > M%(1)) + 2, 1)
  END IF
ELSE 'Se N„o for Setas
  IF M%(1) > M%(4) AND M%(1) < M%(6) AND M%(2) > M%(5) AND M%(2) < M%(7) THEN 'Se No_Quadro
    IF M%(0) = 1 THEN CRT$ = CHR$(0) + CHR$(M%(1) - M%(3) + 230) 'Se Tecla ‚ 1 indica defasagem de linhas
    IF M%(0) = 2 THEN CRT$ = CHR$(SCREEN(M%(1), M%(2)))          'Se Tecla ‚ 2 devolve o caractere sob o mouse
  ELSE 'Se Fora_do_Quadro procura o bot„o pressionado
    A$ = "": I% = 1: X = M%(2)
    DO
      IF I% > 0 THEN A$ = A$ + CHR$(SCREEN(M%(1), X)) ELSE A$ = CHR$(SCREEN(M%(1), X)) + A$
      X = X + I%: IF I% > 0 AND (X > 80 OR RIGHT$(A$, 1) = ">") THEN X = M%(2) - 1: I% = (-1)
    LOOP UNTIL (LEFT$(A$, 1) = "<" AND RIGHT$(A$, 1) = ">") OR X < 1
    B$ = ";<F1><<F2>=<F3>><F4>?<F5>@<F6>A<F7>B<F8>C<F9>D<F10>…<F11>†<F12>h<ALT+F1>i<ALT+F2>Œ<ALT+F12>I<PgUp>Q<PgDw>G<HOME>O<END>R<INS>S<DEL><ESC>" + CHR$(9) + "<TAB>" + CHR$(13) + "<ENTER>"
    CRT$ = "": IF LEN(A$) > 3 THEN X% = INSTR(B$, A$) - 1: IF X% > 1 THEN IF X% > 130 THEN CRT$ = MID$(B$, X%, 1) ELSE CRT$ = CHR$(0) + MID$(B$, X%, 1)
  END IF
END IF
END SUB
SUB CopyTela (I%, L1%, C1%, L2%, C2%, TL$)
DEF SEG = &HB800: X% = 0: IF I% = 0 THEN IL% = (L1% - 1) * 160 - 1: FL% = IL% + (C2% * 2): IL% = IL% + (C1% * 2 - 1): TL$ = STRING$((FL% - IL% + 1) * (L2% - L1% + 1), 32)
FOR L% = L1% TO L2% 'Copia/Recoloca a Janela
  IL% = (L% - 1) * 160 - 1: FL% = IL% + (C2% * 2): IL% = IL% + (C1% * 2 - 1)
  FOR C% = IL% TO FL%
    X% = X% + 1: IF I% = 0 THEN MID$(TL$, X%, 1) = CHR$(PEEK(C%)) ELSE POKE C%, ASC(MID$(TL$, X%, 1))
  NEXT
NEXT: DEF SEG
END SUB
SUB ENTRADA (L1%, C1%, LNH%, CRT$, X$, CJ$)
DO
  LOCATE L1% + 11, C1% + 42: COLOR 7, 5: PRINT TIME$: CRT$ = INKEY$: CALL MOUSE(K%, L%, C%)
  IF L% <> ML% OR C% <> MC% OR K% > 0 THEN
    IF ML% > 0 THEN LOCATE ML%, MC%: COLOR MP%, MF%: PRINT CHR$(SCREEN(ML%, MC%));
    ML% = L%: MC% = C%: MP% = SCREEN(ML%, MC%, 1): MF% = (MP% AND 112) / 16: MP% = MP% AND 15
    LOCATE ML%, MC%: COLOR MF%, MP%: PRINT CHR$(SCREEN(ML%, MC%));
    X$ = MKI$(K%) + MKI$(ML%) + MKI$(MC%)
    IF K% > 0 THEN
      TP = TIMER + .1: DO: CRT$ = INKEY$: LOOP UNTIL TIMER > TP
      CRT$ = MKI$(K%) + MKI$(ML%) + MKI$(MC%) + MKI$(LNH%) + CJ$: CALL CLICK(CRT$)
      DO: LOCATE L1% + 11, C1% + 42: COLOR 7, 5: PRINT TIME$: CALL MOUSE(K%, L%, C%)
      LOOP UNTIL K% = 0 OR C% <> MC% OR L% <> ML% OR (LEFT$(CRT$, 1) = " " AND INSTR("HPIQ", RIGHT$(CRT$, 1)) > 0)
    END IF
  END IF
LOOP UNTIL CRT$ <> "" OR CVI(X$) > 0: COLOR MP%, MF%: LOCATE ML%, MC%: PRINT CHR$(SCREEN(ML%, MC%));
LOCATE L1% + 11, C1% + 42
END SUB
FUNCTION FMT$ (F1%, F2%, F3%, F4%, FI$)
FMT$ = RIGHT$(STR$(F1%), 2) + RIGHT$(STR$(F2%), 2) + RIGHT$(STR$(F3%), 2) + RIGHT$(STR$(F4%), 2) + FI$
END FUNCTION
SUB IMPRIMIR (NA$) 'Imprime na LPT via Bloco_de_Notas
CY$ = "": FOR I& = 1 TO 256: READ T&: CY$ = CY$ + CHR$(T&): NEXT: RESTORE
BUF% = FREEFILE: OPEN NA$ FOR RANDOM SHARED AS BUF% LEN = 1: FIELD BUF%, 1 AS A$
T& = LOF(BUF%): IF T& > 0 THEN F& = T& * 2 + 2: COLOR 7, 0:  ELSE CLOSE : END
FOR I& = T& TO 1 STEP -1
  GET BUF%, I&: IF ASC(A$) > 127 THEN B$ = MID$(CY$, (ASC(A$) - 127) * 2 - 1, 2) ELSE B$ = A$ + CHR$(0)
  LSET A$ = RIGHT$(B$, 1): PUT BUF%, F&: F& = F& - 1: LSET A$ = LEFT$(B$, 1): PUT BUF%, F&: F& = F& - 1
NEXT: LSET A$ = CHR$(254): PUT BUF%, F&: F& = F& - 1: LSET A$ = CHR$(255): PUT BUF%, F&
CLOSE : SHELL "NOTEPAD/P " + NA$: KILL NA$
END SUB
SUB JANELA (L1, C1, L2, C2, COR, MSG$, RDP$)
I = (COR - INT(COR)) * 10: I = INT(I * 10 + .5) / 10
IF I > INT(I) THEN
  I = (I - INT(I)) * 10: I = INT(I * 10 + .5) / 10
  L = VAL(MID$("-++-", I, 1) + "1"): C = VAL(MID$("++--", I, 1) + "2")
  CALL JANELA(L1 + L, C1 + C, L2 + L, C2 + C, 8, MSG$, RDP$)
END IF
COLOR INT(COR), INT((COR - INT(COR)) * 10 + .5)
LOCATE L1, C1: PRINT LEFT$(CHR$(218) + MSG$ + STRING$(78, 196), C2 - C1); CHR$(191);
LOCATE L2, C1: PRINT CHR$(192); RIGHT$(STRING$(78, 196) + RDP$ + CHR$(217), C2 - C1);
FOR I = L1 + 1 TO L2 - 1
  LOCATE I, C1: PRINT CHR$(179); STRING$(C2 - C1 - 1, 32); CHR$(179);
NEXT: LOCATE L1, C1
END SUB
SUB MOUSE (K%, L%, C%)
DIM REG AS RegType: REG.AX = 3: CALL INTERRUPT(51, REG, REG)
K% = REG.BX
L% = REG.DX / 8 + 1: IF L% > 25 THEN L% = 25
C% = REG.CX / 8 + 1: IF C% > 80 THEN C% = 80
END SUB
SUB PSMT (LSP%, LIP%, CLP%, CRP, PLP%, TAP%)
COLOR (CRP - INT(CRP)) * 10, INT(CRP)
LOCATE LSP%, CLP%: IF PLP% > 1 THEN PRINT CHR$(24) ELSE PRINT " "
LOCATE LIP%, CLP%: IF PLP% < TAP% THEN PRINT CHR$(25) ELSE PRINT " "
IF TAP% > LIP% - LSP% + 1 THEN X% = PLP% / ((TAP% + .001) / (LIP% - LSP% - 1)): X% = X% + ABS(X% < 1)
FOR I% = 1 TO LIP% - LSP% - 1: LOCATE I% + LSP%, CLP%: PRINT CHR$(176 + 174 * (I% = X%)): NEXT
END SUB

QuickBasic Cafe Forum

Need help With Leap Year

Need help With Leap Year

Re: Need help With Leap Year

Re: Need help With Leap Year