Ir ao conteúdo
  • Comunicados

    • Gabriel Torres

      Seja um moderador do Clube do Hardware!   12-02-2016

      Prezados membros do Clube do Hardware, Está aberto o processo de seleção de novos moderadores para diversos setores ou áreas do Clube do Hardware. Os requisitos são:   Pelo menos 500 posts e um ano de cadastro; Boa frequência de participação; Ser respeitoso, cordial e educado com os demais membros; Ter bom nível de português; Ter razoável conhecimento da área em que pretende atuar; Saber trabalhar em equipe (com os moderadores, coordenadores e administradores).   Os interessados deverão enviar uma mensagem privada para o usuário @Equipe Clube do Hardware com o título "Candidato a moderador". A mensagem deverá conter respostas às perguntas abaixo:   Qual o seu nome completo? Qual sua data de nascimento? Qual sua formação/profissão? Já atuou como moderador em algo outro fórum, se sim, qual? De forma sucinta, explique o porquê de querer ser moderador do fórum e conte-nos um pouco sobre você.   OBS: Não se trata de função remunerada. Todos que fazem parte do staff são voluntários.
    • DiF

      Poste seus códigos corretamente!   21-05-2016

      Prezados membros do Fórum do Clube do Hardware, O Fórum oferece um recurso chamado CODE, onde o ícone no painel do editor é  <>     O uso deste recurso é  imprescindível para uma melhor leitura, manter a organização, diferenciar de texto comum e principalmente evitar que os compiladores e IDEs acusem erro ao colar um código copiado daqui. Portanto convido-lhes para ler as instruções de como usar este recurso CODE neste tópico:  
Simon Viegas

[Pascal] Projeto UNIT de utilidades.

Recommended Posts

Olá,

Hoje não estou muito bom com as palavras, mas vou resumir mais ou menos a proposta.

Criar uma (ou mais) UNIT(s) que contenham alguns procedimentos notáveis.

Basicamente a ideia é coletar e agrupar idéias, em units, para facilitar o "reuso"...

Em fim, vamos para prática:

Comecei a desenvolver algumas coisas..

Unit CRT_FCH

UNIT CRT_FCH; {versão 0.001}

INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

{ *** CONSTANTES UNIVERSAIS ***}
CONST
ENTER = #13;
BACKSPACE = #08;
ESC = #27;

{ *** Sobre a UNIT ***}
procedure About;
{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
{ *** Da um pause no programa *** }
procedure Pause;
{ *** Formata o texto e a tela do Pascal *** }
procedure Formatar(corTexto, corFundo:byte);
{ *** ler um password *** }
function ReadPWD(tamanho:byte):string;
{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;


{ *** EM DESENVOLVIMENTO *** }

(*
.
.
.
{ *** Imprime o texto centralizado *** }
procedure WriteCet(x,y:byte; msn:string);
{ *** Imprime o texto colorido *** }
procedure WritePic(corT, corF:byte; msn:string);
.
.
.
*)



IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
implementacoes das units declaradas na interface}
uses
CRT;

{ *** Sobre a UNIT ***}
procedure About;
begin
WriteLn;
WriteLn(' Unit obtida no FCH - Forum do Clube do Hardware');
WriteLn;
WriteLn(' Name : CRT_FCH ');
WriteLn(' Author : Simon Viegas, XXXXXX, XXXXX ');
WriteLn(' Description: Unit com algumas funcionalidades ');
WriteLn(' Date : 09/08/09 14:46 ');
WriteLn(' Copyright : Forum Clube do Hardware ');
WriteLn;
WriteLn(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
WriteLn;
end;

{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
begin
WriteLn('{ *** Sobre a UNIT ***}');
WriteLn('procedure About;');
WriteLn('{ *** Ajuda sobre essa Unit ***}');
WriteLn('procedure HELP_CRT_FCH;');
WriteLn('{ *** Da um pause no programa *** }');
WriteLn('procedure Pause;');
WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
WriteLn('procedure Formatar(corTexto, corFundo:byte);');
WriteLn('{ *** ler um password *** }');
WriteLn('function ReadPWD(tamanho:byte):string;');
WriteLn('{ *** ler um password (e desce uma linha) *** }');
WriteLn('function ReadPWDln(tamanho:byte):string;');
pause;
end;

{ *** Da um pause no prgrama *** }
procedure pause;
begin
WriteLn;
TextAttr:=TextAttr+Blink;
Write('Precione qualquer tecla para continuar');
TextAttr:=TextAttr-Blink;
ReadKey;
end;

{ *** Formata o texto e a tela do Pacal *** }
procedure formatar(corTexto, corFundo:byte);
begin
TextColor(corTexto);
TextBackGround(corFundo);
end;

{ *** ler um password *** }
function readPWD(tamanho:byte):string;
type
T_Senha = Array [1..255] of Char;
var
caractere :char; {caractere lido pelo usuario}
cont :byte; {contador de teclas já lidas}
senha_tmp :string;
v_senha :T_Senha; {a senha em si}
i :byte; {usado no for}
begin
cont:= 0; {zera o contador de caracteres já usados (é necessário)}
Repeat
caractere:=readkey; {ler a tecla digitada}
case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
{caso seja um alfanumérico}
'A' .. 'Z',
'0' .. '9' : begin
if cont<tamanho then
begin
inc(cont); {o mesmo que cont:= cont + 1;}
v_senha[cont]:= caractere; {armazena o caracteres}
write('*'); {imprime um "*" (ocultando a senha)}
end;
end;
{caso queira apagar uma linha}
BACKSPACE : begin
if cont>=1 then
begin
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
write(' '); {"apaga" um caractere}
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
end;
end;
end;{fim case}
Until(caractere = ENTER){ or (cont > max)};
{retorna a senha via function}
senha_tmp:='';
For i:= 1 to cont do
senha_tmp:=senha_tmp+v_senha[i];
readPWD:=senha_tmp;
end;

{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;
begin
ReadPWDln:=ReadPWD(tamanho);
WriteLn;
end;

begin
ClrScr; {limpa a tela}
Formatar(White,Black); {formata a tela}
About; {exibe o "sobre" da unit}
Pause; {da uma pause}
ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
end.

Aqui um programa para testar o "PassWord"

PROGRAM testeUnitPassword;
(*
Name : Teste de Login
Author : Simon Viegas, XXXXXX, XXXXX
Description: Programa que testa a unit
Date : 09/08/09 14:46
Copyright : Forum Clube do Hardware
*)

USES
CRT, {biblioteca com comandos extas}
CRT_FCH;

CONST
TamanhoSenha = 8;
{ *** Tela de Login ***}
procedure telaLogin(x,y:byte);
var
x1, {coordenada X}
y1 : byte; {coordenada Y}
usuario : String; {login do usuario}
senha : String; {senha do usuario}

begin
GotoXY(x,y);
Write(' ********* LOGIN DO USUÁRIO ********* ');
GotoXY(x,y+3);
Write(' LOGIN : ');
x1:=WhereX; y1:=WhereY; {copia a posicao para onde vai o LOGIN}
GotoXY(x,y+4);
Write(' SENHA (max ',TamanhoSenha:3,') : ');
GotoXY(x1,y1);
ReadLn(usuario);
GotoXY(x1,y1+1);
senha:=ReadPWDln(TamanhoSenha); {unit CRT_FCR (Forum Clube do Hardware}
Writeln;
Writeln('Senha digitada ',senha);
end;

CONST
{posição onda vai ficar a tela de login}
x=10; {coordenada X}
y=5; {coordenada Y}


BEGIN
{preparando o layout}
Formatar(Yellow,Black); {unit CRT_FCH}
ClrScr;

WriteLn;
WriteLn;
{imprimindo a tela e lendo dados}
telaLogin(x,y);
ReadKey;
END.

Em fim, o que vocês acham da ideia....

Obs.: Os código que enviei foram só como base, tudo pode ser modificado/melhorado...

Fico no aguardo de sugestões.

Abraços

Compartilhar este post


Link para o post
Compartilhar em outros sites
Olá,

Hoje não estou muito bom com as palavras, mas vou resumir mais ou menos a proposta.

Basicamente a ideia é coletar e agrupar idéias, em units, para facilitar o "reuso"...

Em fim, vamos para prática:

Comecei a desenvolver algumas coisas..

Unit CRT_FCH



INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

{ *** CONSTANTES UNIVERSAIS ***}
CONST
ENTER = #13;
BACKSPACE = #08;
ESC = #27;

{ *** Sobre a UNIT ***}
procedure About;
{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
{ *** Da um pause no programa *** }
procedure Pause;
{ *** Formata o texto e a tela do Pascal *** }
procedure Formatar(corTexto, corFundo:byte);
{ *** ler um password *** }
function ReadPWD(tamanho:byte):string;
{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;


{ *** EM DESENVOLVIMENTO *** }

(*
.
.
.
{ *** Imprime o texto centralizado *** }
procedure WriteCet(x,y:byte; msn:string);
{ *** Imprime o texto colorido *** }
procedure WritePic(corT, corF:byte; msn:string);
.
.
.
*)



IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
implementacoes das units declaradas na interface}
uses
CRT;

{ *** Sobre a UNIT ***}
procedure About;
begin
WriteLn;
WriteLn(' Unit obtida no FCH - Forum do Clube do Hardware');
WriteLn;
WriteLn(' Name : CRT_FCH ');
WriteLn(' Author : Simon Viegas, XXXXXX, XXXXX ');
WriteLn(' Description: Unit com algumas funcionalidades ');
WriteLn(' Date : 09/08/09 14:46 ');
WriteLn(' Copyright : Forum Clube do Hardware ');
WriteLn;
WriteLn(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
WriteLn;
end;

{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
begin
WriteLn('{ *** Sobre a UNIT ***}');
WriteLn('procedure About;');
WriteLn('{ *** Ajuda sobre essa Unit ***}');
WriteLn('procedure HELP_CRT_FCH;');
WriteLn('{ *** Da um pause no programa *** }');
WriteLn('procedure Pause;');
WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
WriteLn('procedure Formatar(corTexto, corFundo:byte);');
WriteLn('{ *** ler um password *** }');
WriteLn('function ReadPWD(tamanho:byte):string;');
WriteLn('{ *** ler um password (e desce uma linha) *** }');
WriteLn('function ReadPWDln(tamanho:byte):string;');
pause;
end;

{ *** Da um pause no prgrama *** }
procedure pause;
begin
WriteLn;
TextAttr:=TextAttr+Blink;
Write('Precione qualquer tecla para continuar');
TextAttr:=TextAttr-Blink;
ReadKey;
end;

{ *** Formata o texto e a tela do Pacal *** }
procedure formatar(corTexto, corFundo:byte);
begin
TextColor(corTexto);
TextBackGround(corFundo);
end;

{ *** ler um password *** }
function readPWD(tamanho:byte):string;
type
T_Senha = Array [1..255] of Char;
var
caractere :char; {caractere lido pelo usuario}
cont :byte; {contador de teclas já lidas}
senha_tmp :string;
v_senha :T_Senha; {a senha em si}
i :byte; {usado no for}
begin
cont:= 0; {zera o contador de caracteres já usados (é necessário)}
Repeat
caractere:=readkey; {ler a tecla digitada}
case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
{caso seja um alfanumérico}
'A' .. 'Z',
'0' .. '9' : begin
if cont<tamanho then
begin
inc(cont); {o mesmo que cont:= cont + 1;}
v_senha[cont]:= caractere; {armazena o caracteres}
write('*'); {imprime um "*" (ocultando a senha)}
end;
end;
{caso queira apagar uma linha}
BACKSPACE : begin
if cont>=1 then
begin
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
write(' '); {"apaga" um caractere}
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
end;
end;
end;{fim case}
Until(caractere = ENTER){ or (cont > max)};
{retorna a senha via function}
senha_tmp:='';
For i:= 1 to cont do
senha_tmp:=senha_tmp+v_senha[i];
readPWD:=senha_tmp;
end;

{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;
begin
ReadPWDln:=ReadPWD(tamanho);
WriteLn;
end;

begin
ClrScr; {limpa a tela}
Formatar(White,Black); {formata a tela}
About; {exibe o "sobre" da unit}
Pause; {da uma pause}
ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
end.
UNIT CRT_FCH; {versão 0.001}

Aqui um programa para testar o "PassWord"


(*
Name : Teste de Login
Author : Simon Viegas, XXXXXX, XXXXX
Description: Programa que testa a unit
Date : 09/08/09 14:46
Copyright : Forum Clube do Hardware
*)

USES
CRT, {biblioteca com comandos extas}
CRT_FCH;

CONST
TamanhoSenha = 8;
{ *** Tela de Login ***}
procedure telaLogin(x,y:byte);
var
x1, {coordenada X}
y1 : byte; {coordenada Y}
usuario : String; {login do usuario}
senha : String; {senha do usuario}

begin
GotoXY(x,y);
Write(' ********* LOGIN DO USUÁRIO ********* ');
GotoXY(x,y+3);
Write(' LOGIN : ');
x1:=WhereX; y1:=WhereY; {copia a posicao para onde vai o LOGIN}
GotoXY(x,y+4);
Write(' SENHA (max ',TamanhoSenha:3,') : ');
GotoXY(x1,y1);
ReadLn(usuario);
GotoXY(x1,y1+1);
senha:=ReadPWDln(TamanhoSenha); {unit CRT_FCR (Forum Clube do Hardware}
Writeln;
Writeln('Senha digitada ',senha);
end;

CONST
{posição onda vai ficar a tela de login}
x=10; {coordenada X}
y=5; {coordenada Y}


BEGIN
{preparando o layout}
Formatar(Yellow,Black); {unit CRT_FCH}
ClrScr;

WriteLn;
WriteLn;
{imprimindo a tela e lendo dados}
telaLogin(x,y);
ReadKey;
END.
PROGRAM testeUnitPassword;

Em fim, o que vocês acham da ideia....

Obs.: Os código que enviei foram só como base, tudo pode ser modificado/melhorado...

Fico no aguardo de sugestões.

Abraços


{ *** Da um pause no prgrama *** }
procedure pause;
begin
WriteLn;
TextAttr:=TextAttr+Blink;
Write('Precione qualquer tecla para continuar');
TextAttr:=TextAttr-Blink;
ReadKey;
end;

Olá!

Legal essa Unit...

:confused:

TextAttr:=TextAttr+Blink;

O que significa?

TextAttr é uma variável?

Obs.: Tenho que descobrir como fazer funcionar Units no Dev-Pascal!!!:lol:

Compartilhar este post


Link para o post
Compartilhar em outros sites
  • Autor do tópico
  • Olá!

    Legal essa Unit...

    :confused:

    TextAttr:=TextAttr+Blink;

    O que significa?

    TextAttr é uma variável?

    Obs.: Tenho que descobrir como fazer funcionar Units no Dev-Pascal!!!:lol:

    Olá,

    Isso, é uma variável que armazena "os atributos do texto". É como se fosse uma combinação do valor do TextColor + TextBackGround (cor do texto e cor do fundo respectivamente).

    Essa lógica

    TextAttr:=TextAttr+Blink;

    eu tinha acabado de inventar... não sei se vai funcionar muito bem em "todas as configurações de cores"...

    Mas é mais ou menos isso:

    TextAttr:=TextAttr+Blink;

    Atritubos atuais = Atributos atuais + fazer piscar

    Idealizei mais ou menos isso. Fiz os testes e funcionou (pelo menos no dia, rs).

    Segundo o Help do Turbo Pascal 7.1:

    (em inglês)

       TextAttr (variable)     (Crt unit)
    ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
    Stores currently selected text attributes

    The text attributes are normally set through calls to TextColor and
    TextBackground.

    However, you can also set them by directly storing a value in TextAttr.

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites
  • Autor do tópico
  • Adicionei mais alguns comandos...

    Esse abaixo foi comentado recetemente aqui no Fórum... é bem legal.

    Uma alternativa para o Delay()

    {da um delay no pascal em milissegundos}
    procedure aguardar(t:real);
    function timer:real;
    var
    hour,
    minute,
    second,
    sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    {//acho que dá para otimizar essa fórmula abaixo!!!}
    timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
    end;

    var
    t1 :real;
    begin
    t1:=timer;
    repeat until timer>t1+(100*t)/1000;
    end;

    Vide este tópico...

    Caso queira limpar uma linha específica.

    procedure limparErro(x, y: byte);  {Apagar linha de erro}
    begin
    gotoXY(x,y); clreol;
    gotoXY(x,y);
    end;

    Neste caso, vai limpar o trecho e vai reposicionar no início de onde foi apagado.

    Eu acho que tenho ums comandos legais aqui em casa, mas não estou encontrando...

    A medida que for encontrando vou inserindo na Unit..

    e aí galera, mas uma sugestão?

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites
    Adicionei mais alguns comandos...

    Esse abaixo foi comentado recetemente aqui no Fórum... é bem legal.

    Uma alternativa para o Delay()


    procedure aguardar(t:real);
    function timer:real;
    var
    hour,
    minute,
    second,
    sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    {//acho que dá para otimizar essa fórmula abaixo!!!}
    timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
    end;

    var
    t1 :real;
    begin
    t1:=timer;
    repeat until timer>t1+(100*t)/1000;
    end;
    {da um delay no pascal em milissegundos}

    Vide este tópico...

    Caso queira limpar uma linha específica.


    begin
    gotoXY(x,y); clreol;
    gotoXY(x,y);
    end;
    procedure limparErro(x, y: byte);  {Apagar linha de erro}

    Neste caso, vai limpar o trecho e vai reposicionar no início de onde foi apagado.

    Eu acho que tenho ums comandos legais aqui em casa, mas não estou encontrando...

    A medida que for encontrando vou inserindo na Unit..

    e aí galera, mas uma sugestão?

    {da um delay no pascal em milissegundos}
    procedure aguardar(t:real);
    function timer:real;
    var
    hour,
    minute,
    second,
    sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    {//acho que dá para otimizar essa fórmula abaixo!!!}
    timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
    end;

    var
    t1 :real;
    begin
    t1:=timer;
    repeat until timer>t1+(100*t)/1000;
    end;

    Bem,

    quanto à linha:

    repeat until timer>t1+(100*t)/1000;

    Poderíamos escrever:

    repeat until timer>t1+t/10;

    Uma outra opção seria fazer

    timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;

    //transformar em milissegundos em vez de centésimos de segundos... :D

    Dessa forma, o laço ficaria:

    repeat until timer>t1+t;

    No Código:

    {da um delay no pascal em milissegundos}
    procedure aguardar(t:real);
    function timer:real;
    var
    hour,
    minute,
    second,
    sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    {//Converte a hora capturada em milissegundos}
    [b][COLOR="blue"]timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;[/COLOR][/b]
    end;

    var
    t1 :real;
    begin
    t1:=timer;
    [b][COLOR="Blue"]repeat until timer>t1+t;[/COLOR][/b]
    end;

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites

    Olá, pessoal!

    Tem mais uma função legal, a que calcula a potência de um número para expoentes inteiros:


    function Potencia(base: real; expoente: integer): double;
    function Modulo(x: integer): Integer;
    Begin
    Modulo:= x;
    if(x<0) then
    Modulo:= -Modulo;
    End;

    Var
    i: integer;
    Begin
    Potencia:= 1;
    if(expoente<>0) then Begin
    for i:= 1 to Modulo(expoente) do
    Potencia:= Potencia *base;
    if(expoente<0) then
    Potencia:= 1/Potencia;
    End;
    End;

    T+

    :)

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites
  • Autor do tópico
  • Saiu mais uma versão quentinha... tem poucas mudanças, mas já é um avanço.. ^_^

    Versão 0.002

    Adicionado:

    { *** imprimi texto de modo centralizado ***}

    procedure WritCet (texto:string);

    { *** Da um delay no pascal em milissegundos}

    procedure Aguardar(t:real);

    { *** Limpa uma linha especifica ***}

    procedure LimparLinha(x, y: byte);

    {*** Calcula potencia de um numero para expoentes inteiros ***}

    function Potencia(base: real; expoente: integer): double;

    Dúvidas / Elogios / Críticas / Sugetões é só postar!!!

    UNIT CRT_FCH

    {$N+} {habilita calculos com double}
    UNIT CRT_FCH; {versão 0.002}

    INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

    { *** CONSTANTES UNIVERSAIS ***}
    CONST
    ENTER = #13;
    BACKSPACE = #08;
    ESC = #27;

    { *** Sobre a UNIT ***}
    procedure About;
    { *** Ajuda sobre essa Unit ***}
    procedure HELP_CRT_FCH;
    { *** Da um pause no programa *** }
    procedure Pause;
    { *** Formata o texto e a tela do Pascal *** }
    procedure Formatar(corTexto, corFundo:byte);
    { *** ler um password *** }
    function ReadPWD(tamanho:byte):string;
    { *** ler um password (e desce uma linha) *** }
    function ReadPWDln(tamanho:byte):string;


    [COLOR="Red"]{versao 002}


    { *** imprimi texto de modo centralizado ***}
    procedure WritCet (texto:string);
    { *** Da um delay no pascal em milissegundos}
    procedure Aguardar(t:real);
    { *** Limpa uma linha especifica ***}
    procedure LimparLinha(x, y: byte);
    {*** Calcula potencia de um numero para expoentes inteiros ***}
    function Potencia(base: real; expoente: integer): double;[/COLOR]


    IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
    implementacoes das units declaradas na interface}
    uses
    CRT, {carrega comando como ReadKey, TextColor, TextBackGround, ClrScr}
    DOS ; {carrega comando como GetTime, GetDate, DateTime}

    { *** Sobre a UNIT ***}
    procedure About;
    begin
    WriteLn;
    WriteLn(' Unit obtida no FCH - Forum do Clube do Hardware');
    WriteLn;
    WriteLn(' Name : CRT_FCH ');
    WriteLn(' Author : Simon Viegas, gu_ludo, XXXXX ');
    WriteLn(' Description: Unit com algumas funcionalidades ');
    WriteLn(' Date : 09/08/09 14:46 ');
    WriteLn(' Copyright : Forum Clube do Hardware ');
    WriteLn;
    WriteLn(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
    WriteLn;
    end;

    { *** Ajuda sobre essa Unit ***}
    procedure HELP_CRT_FCH;
    begin
    WriteLn('{versao001}');
    WriteLn('{ *** Sobre a UNIT ***}');
    WriteLn('procedure About;');
    WriteLn('{ *** Ajuda sobre essa Unit ***}');
    WriteLn('procedure HELP_CRT_FCH;');
    WriteLn('{ *** Da um pause no programa *** }');
    WriteLn('procedure Pause;');
    WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
    WriteLn('procedure Formatar(corTexto, corFundo:byte);');
    WriteLn('{ *** ler um password *** }');
    WriteLn('function ReadPWD(tamanho:byte):string;');
    WriteLn('{ *** ler um password (e desce uma linha) *** }');
    WriteLn('function ReadPWDln(tamanho:byte):string;');
    [COLOR="Red"] WriteLn('{versao 002}');
    WriteLn('{ *** imprimi texto de modo centralizado ***}');
    WriteLn('procedure WritCet (texto:string);');
    WriteLn('{ *** Da um delay no pascal em milissegundos}');
    WriteLn('procedure Aguardar(t:real);');
    WriteLn('{ *** Limpa uma linha especifica ***}');
    WriteLn('procedure LimparLinha(x, y: byte);');
    WriteLn('{*** Calcula potencia de um numero para expoentes inteiros ***}');
    WriteLn('function Potencia(base: real; expoente: integer): double;');[/COLOR]
    pause;
    end;

    { *** Da um pause no prgrama *** }
    procedure pause;
    begin
    WriteLn;
    TextAttr:=TextAttr+Blink;
    Write('Precione qualquer tecla para continuar');
    TextAttr:=TextAttr-Blink;
    ReadKey;
    end;

    { *** Formata o texto e a tela do Pacal *** }
    procedure formatar(corTexto, corFundo:byte);
    begin
    TextColor(corTexto);
    TextBackGround(corFundo);
    end;

    { *** ler um password *** }
    function readPWD(tamanho:byte):string;
    type
    T_Senha = Array [1..255] of Char;
    var
    caractere :char; {caractere lido pelo usuario}
    cont :byte; {contador de teclas já lidas}
    senha_tmp :string;
    v_senha :T_Senha; {a senha em si}
    i :byte; {usado no for}
    begin
    cont:= 0; {zera o contador de caracteres já usados (é necessário)}
    Repeat
    caractere:=readkey; {ler a tecla digitada}
    case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
    {caso seja um alfanumérico}
    'A' .. 'Z',
    '0' .. '9' : begin
    if cont<tamanho then
    begin
    inc(cont); {o mesmo que cont:= cont + 1;}
    v_senha[cont]:= caractere; {armazena o caracteres}
    write('*'); {imprime um "*" (ocultando a senha)}
    end;
    end;
    {caso queira apagar uma linha}
    BACKSPACE : begin
    if cont>=1 then
    begin
    gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
    write(' '); {"apaga" um caractere}
    gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
    dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
    end;
    end;
    end;{fim case}
    Until(caractere = ENTER){ or (cont > max)};
    {retorna a senha via function}
    senha_tmp:='';
    For i:= 1 to cont do
    senha_tmp:=senha_tmp+v_senha[i];
    readPWD:=senha_tmp;
    end;

    { *** ler um password (e desce uma linha) *** }
    function ReadPWDln(tamanho:byte):string;
    begin
    ReadPWDln:=ReadPWD(tamanho);
    WriteLn;
    end;

    [COLOR="Red"]{versao 002}
    { *** imprimi texto de modo centralizado ***}
    procedure WritCet (texto:string);
    begin
    gotoXY(40-(length(texto) div 2), whereY); {centraliza}
    writeln(texto);
    end;

    {da um delay no pascal em milissegundos}
    procedure Aguardar(t:real);
    function timer:real;
    var
    hour,
    minute,
    second,
    sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    {//Converte a hora capturada em milissegundos}
    timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;
    end;

    var
    t1 :real;
    begin
    t1:=timer;
    repeat until timer>t1+t;
    end;

    { *** Limpa uma linha especifica ***}
    procedure LimparLinha(x, y: byte);
    begin
    GotoXY(x,y); clreol;
    GotoXY(x,y);
    end;

    {*** Calcula potencia de um numero para expoentes inteiros ***}
    function Potencia(base: real; expoente: integer): double;
    var
    i :word;
    tmp_Potencia :double;
    begin
    tmp_Potencia:= 1; {valor inicial e serve tambem caso expoente seja 0}
    if (expoente<>0) then
    begin
    {calcula a potencia con a base em 'valor absoluto'}
    for i:=1 to Abs(expoente) do
    tmp_Potencia := tmp_Potencia*base;
    {se o expoente for positivo}
    if (expoente>0) then
    Potencia:=tmp_Potencia
    {se o expoente for negaivo}
    else
    Potencia:=1/tmp_Potencia;
    end;
    end;[/COLOR]


    begin
    ClrScr; {limpa a tela}
    Formatar(White,Black); {formata a tela}
    About; {exibe o "sobre" da unit}
    Pause; {da uma pause}
    ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
    end.

    Abraços

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites
  • Autor do tópico
  • Adicionamos mais alguns recursos...

    1) Posto o ClrScr depois do Formatar na "Begin/End" da unit;

    2) Removido o "pause" do HELP_CRT_FCH;

    3) Adicionado as constantes das principais teclas do teclado;

    4) Adicionado os comandos:

    procedure WritePic (texto: string; cor: byte);

    { *** Imprime texto colorido - nao desce a linha *** }

    procedure WritelnPic (texto: string; cor: byte);

    { *** Imprime texto colorido - desce a linha *** }

    procedure WriteXY(x,y:byte; texto:String);

    {imprime texto em determinada posicao e retorna o cursor na posicao original}

    4) Adicionado as variaveis

    XOld,YOld :byte; {coodenadas do curso atual}

    textAttrOld :word; {atributos de texto atual}

    CÓDIGO Versão 0.010

    {$N+} {habilita calculos com double}
    UNIT CRT_FCH; {versão 0.010}

    INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

    { *** CONSTANTES UNIVERSAIS ***}
    [COLOR="Red"]const {Codigo ASCII de Teclas}
    F1=#59; F2=#60; F3=#61; F4=#62; F5=#63; F6=#64;
    F7=#65; F8=#66; F9=#67; F10=#68; F11=#69; F12=#70;
    ENTER=#13; ESC=#27; BACKSPACE=#8; TABE =#9; ESPACO=' ';
    SetaCima=#72; SetaBaixo=#80; SeteEsqueda=#75; SetaDireita=#77;[/COLOR]

    procedure About;
    { *** Sobre a UNIT ***}

    procedure HELP_CRT_FCH;
    { *** Ajuda sobre essa Unit ***}

    procedure Pause;
    { *** Da um pause no programa *** }

    procedure Formatar(corTexto, corFundo:byte);
    { *** Formata o texto e a tela do Pascal *** }

    function ReadPWD(tamanho:byte):string;
    { *** ler um password *** }

    function ReadPWDln(tamanho:byte):string;
    { *** ler um password (e desce uma linha) *** }

    procedure Aguardar(t:real);
    { *** Da um delay no pascal em milissegundos}

    procedure LimparLinha(x, y: byte);
    { *** Limpa uma linha especifica ***}

    function Potencia(base: real; expoente: integer): double;
    { *** Calcula potencia de um numero para expoentes inteiros ***}


    [COLOR="Red"]{
    ****************************************************************************
    ROTINAS PARA IMPRESSAO DE CARACTERS
    ****************************************************************************
    }

    (* BASICOS *)

    procedure WriteCet(texto:String);
    { *** Imprimi texto de modo centralizado *** }

    procedure WritePic(cor:byte; texto:String);
    {imprime texto colorido - nao desce a linha}

    procedure WriteLNPic(cor:byte; texto:String);
    { *** Imprime texto colorido - desce a linha *** }

    procedure WriteXY(x,y:byte; texto: string);
    {imprime texto em determinada posicao e retorna o cursor na posicao original}[/COLOR]



    IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
    implementacoes das units declaradas na interface}
    uses
    CRT, {carrega comando como ReadKey, TextColor, TextBackGround, ClrScr}
    DOS ; {carrega comando como GetTime, GetDate, DateTime}

    var
    XOld,YOld :byte; {coodenadas do curso atual}
    textAttrOld :word; {atributos de texto atual}


    { *** Sobre a UNIT ***}
    procedure About;
    begin
    WriteCet(' Unit obtida no FCH - Forum do Clube do Hardware');
    WriteLn;
    WriteLn(' Name : CRT_FCH ');
    WriteLn(' Author : Simon Viegas, gu_ludo, XXXXX ');
    WriteLn(' Description: Unit com algumas funcionalidades ');
    WriteLn(' Date : 09/08/09 14:46 ');
    WriteLn(' Copyright : Forum Clube do Hardware ');
    WriteLn;
    WriteCet(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
    end;

    { *** Ajuda sobre essa Unit ***}
    procedure HELP_CRT_FCH;
    begin
    WriteLn('{versao001}');
    WriteLn('{ *** Sobre a UNIT ***}');
    WriteLn('procedure About;');
    WriteLn('{ *** Ajuda sobre essa Unit ***}');
    WriteLn('procedure HELP_CRT_FCH;');
    WriteLn('{ *** Da um pause no programa *** }');
    WriteLn('procedure Pause;');
    WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
    WriteLn('procedure Formatar(corTexto, corFundo:byte);');
    WriteLn('{ *** ler um password *** }');
    WriteLn('function ReadPWD(tamanho:byte):string;');
    WriteLn('{ *** ler um password (e desce uma linha) *** }');
    WriteLn('function ReadPWDln(tamanho:byte):string;');
    WriteLn('{versao 002}');
    WriteLn('{ *** Da um delay no pascal em milissegundos}');
    WriteLn('procedure Aguardar(t:real);');
    WriteLn('{ *** Limpa uma linha especifica ***}');
    WriteLn('procedure LimparLinha(x, y: byte);');
    WriteLn('{*** Calcula potencia de um numero para expoentes inteiros ***}');
    WriteLn('function Potencia(base: real; expoente: integer): double;');
    end;

    { *** Da um pause no prgrama *** }
    procedure pause;
    begin
    WriteLn;
    TextAttr:=TextAttr+Blink;
    Write('Precione qualquer tecla para continuar');
    TextAttr:=TextAttr-Blink;
    ReadKey;
    end;

    { *** Formata o texto e a tela do Pacal *** }
    procedure formatar(corTexto, corFundo:byte);
    begin
    TextColor(corTexto);
    TextBackGround(corFundo);
    end;

    { *** ler um password *** }
    function readPWD(tamanho:byte):string;
    type
    T_Senha = Array [1..255] of Char;
    var
    caractere :char; {caractere lido pelo usuario}
    cont :byte; {contador de teclas já lidas}
    senha_tmp :string;
    v_senha :T_Senha; {a senha em si}
    i :byte; {usado no for}
    begin
    cont:= 0; {zera o contador de caracteres já usados (é necessário)}
    Repeat
    caractere:=readkey; {ler a tecla digitada}
    case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
    {caso seja um alfanumérico}
    'A' .. 'Z',
    '0' .. '9' : begin
    if cont<tamanho then
    begin
    inc(cont); {o mesmo que cont:= cont + 1;}
    v_senha[cont]:= caractere; {armazena o caracteres}
    write('*'); {imprime um "*" (ocultando a senha)}
    end;
    end;
    {caso queira apagar uma linha}
    BACKSPACE : begin
    if cont>=1 then
    begin
    gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
    write(' '); {"apaga" um caractere}
    gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
    dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
    end;
    end;
    end;{fim case}
    Until(caractere = ENTER){ or (cont > max)};
    {retorna a senha via function}
    senha_tmp:='';
    For i:= 1 to cont do
    senha_tmp:=senha_tmp+v_senha[i];
    readPWD:=senha_tmp;
    end;

    { *** ler um password (e desce uma linha) *** }
    function ReadPWDln(tamanho:byte):string;
    begin
    ReadPWDln:=ReadPWD(tamanho);
    WriteLn;
    end;

    {da um delay no pascal em milissegundos}
    procedure Aguardar(t:real);
    function timer:real;
    var
    hour,
    minute,
    second,
    sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    {//Converte a hora capturada em milissegundos}
    timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;
    end;

    var
    t1 :real;
    begin
    t1:=timer;
    repeat until timer>t1+t;
    end;

    { *** Limpa uma linha especifica ***}
    procedure LimparLinha(x, y: byte);
    begin
    GotoXY(x,y); clreol;
    GotoXY(x,y);
    end;

    {*** Calcula potencia de um numero para expoentes inteiros ***}
    function Potencia(base: real; expoente: integer): double;
    var
    i :word;
    tmp_Potencia :double;
    begin
    tmp_Potencia:= 1; {valor inicial e serve tambem caso expoente seja 0}
    if (expoente<>0) then
    begin
    {calcula a potencia con a base em 'valor absoluto'}
    for i:=1 to Abs(expoente) do
    tmp_Potencia := tmp_Potencia*base;
    {se o expoente for positivo}
    if (expoente>0) then
    Potencia:=tmp_Potencia
    {se o expoente for negaivo}
    else
    Potencia:=1/tmp_Potencia;
    end;
    end;



    [COLOR="Red"]{
    ****************************************************************************
    ROTINAS PARA IMPRESSAO DE CARACTERS
    ****************************************************************************
    }

    procedure WriteCet (texto:string);
    { *** imprimi texto de modo centralizado ***}
    begin
    gotoXY(40-(length(texto) div 2), whereY); {centraliza}
    writeln(texto);
    end;

    procedure WritePic (cor:byte; texto:String);
    {imprime texto colorido - nao desce a linha}
    begin
    textAttrOld:=textAttr; {copia dos atributos de texto atual}
    textColor(cor);
    write(texto);
    textAttr:=textAttrOld; {reconfigura os atributos de texto}
    end;

    procedure WriteLNPic (cor:byte; texto:String);
    {imprime texto colorido - desce a linha}
    begin
    writePic(cor,texto);
    writeln;
    end;

    procedure WriteXY(x,y:byte; texto:String);
    {imprime texto em determinada posicao e retorna o cursor na posicao original}
    begin
    XOld:=whereX; YOld:=whereY; {copia as coodenadas do curso atual}
    gotoXY(x,y);
    write(texto);
    gotoXY(XOld,YOld); {retorna as coodenadas do curso}
    end;[/COLOR]

    begin
    Formatar(White,Black); {formata a tela}
    ClrScr; {limpa a tela}
    About; {exibe o "sobre" da unit}
    Pause; {da uma pause}
    ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
    end.

    Abraços

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites

    Algumas ideias:


    uses
    crt;
    var
    x,y,resultado:real;
    p,q:integer;

    // funcao modulo |x|
    function Modulo (k:real):real;
    begin
    if k<0 then
    Modulo:=-1*k
    else
    Modulo:=k;
    end;

    // funcao calcular o maximo divisor comum
    function MDC (a,b:integer):integer;
    var r:integer;
    begin
    r := a mod b;
    while (r<>0) do
    begin
    a := b;
    b := r;
    r := a mod b;
    end;
    MDC:=trunc(modulo(B)); //trunc inutil mas essencial
    end;

    // funcao calcular o minimo multiplo comum
    function MMC (x1,x2:integer):integer;
    begin
    MMC:=x1 * x2 div MDC(x1,x2);
    end;

    // funcao contar casas decimais
    function CasasDecimais(z1:real):integer;
    const
    precisao=15;
    var
    EmString:string;
    passo:shortint;
    begin
    str(z1:1:precisao,EmString); //converte para string com 'precisao' (20) casas decimais
    delete(EmString,1,Pos('.',EmString)); //apaga tudo ate o ponto
    passo:=precisao;
    while EmString[passo]='0' do //apaga os zeros do final
    begin
    delete(EmString,passo,1);
    passo:=passo-1;
    end;
    CasasDecimais:=length(EmString); //conta as casas
    end;

    // converter decimal em fracao
    procedure DecimalEmFracao (z1:real; var p,q:integer);
    var p2:integer;
    begin
    p:=trunc(z1*exp(ln(10)*CasasDecimais(z1)));
    q:=trunc(exp(ln(10)*CasasDecimais(z1)));
    // o trunc nao vai mudar nada, apenas mudar para tipo integer
    // tem-se: z1 = p/q
    // simplificar
    p2:=p; //guardar o valor de p em p2
    p:=p div MDC(p,q); //simplificar o numerador
    q:=q div MDC(p2,q); //simplificar o denominador
    { writeln(z1,' = ',p,' / ',q); }
    // z1 = p / q
    // simplificado
    end;

    // calcular a potencia
    function Potencia(base,expoente:real):real;
    const
    indefinido=0;
    begin
    if base>0 then //base positiva
    Potencia:=exp(ln(base)*expoente) // Potencia = base ^ expoente
    else //base negativa ou nula
    if base=0 then //base nula
    if expoente>0 then //base nula e expoente positivo
    Potencia:=0
    else //base nula e expoente negativo ou nulo
    Potencia:=indefinido
    else //base negativa
    begin
    DecimalEmFracao(expoente,p,q); // tem-se expoente=p/q
    if q mod 2 = 0 then // indice da raiz par
    Potencia:=indefinido
    else // indice da raiz impar
    if p mod 2 = 1 then // novo expoente par
    Potencia:=-exp(ln(modulo(base))*expoente) // Potencia=-(|base|) ^ (expoente)
    else
    Potencia:=exp(ln(modulo(base))*expoente); // Potencia= (|base|) ^ (expoente)
    end;

    // calcular raiz
    (*
    function Raiz (indice,radicando:real) :real;
    {var...;}
    begin
    Raiz:=Potencia(radicando,1/indice);
    end;
    *)
    end;

    Begin

    (*
    // testar modulo
    while true do
    begin
    readln(x);
    writeln(modulo(x):0:4);
    writeln;
    end;
    *)

    (*
    // testar potencia
    while true do
    begin
    readln(x,y);
    resultado:=Potencia(x,y);
    gotoxy(1,wherey+3);
    if x>= 0 then write(x:0:2) else write('(',x:0:2,')');
    gotoxy(wherex,wherey-1);
    write(y:0:2);
    gotoxy(wherex+1,wherey+1);
    write('= ',resultado:0:8);
    writeln;
    gotoxy(1,wherey+4);
    end;
    *)

    (*
    //testar mdc
    while true do begin
    readln(x,y);
    writeln(MDC(trunc(x),trunc(y)));
    end;
    *)

    (*
    //testar mmc
    while true do begin
    readln(x,y);
    writeln(MMC(trunc(x),trunc(y)));
    end;
    *)

    (*
    // testar decimal em fracao
    while true do begin
    readln(x);
    DecimalEmFracao(x,p,q);
    writeln('x = ',p,' / ',q);
    end;
    *)

    (*
    // testar numero de casas
    while true do begin
    readln(x);
    writeln(CasasDecimais(x));
    end;
    *)

    End.
    program teste_unit;

    Fiz como um programa que testa cada utilidade.

    Para testar, basta retirar os "(*" e "*)" do trecho de teste desejado.

    O que faz:

    • calcula o módulo de um número real;
    • calcula o mínimo múltiplo comum entre dois números inteiros;
    • calcula o máximo divisor comum entre dois números inteiros;
    • conta o número de casas decimais de um número real (necessária para os próximos);
    • converte um número real numa fração de numerador e denominador inteiros e primos entre si;
    • calcula potências e raízes de dois números REAIS;

    Obrigado pela atenção.

    Editado por viniciusbmatos
    Mais explicações

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites

    Se ainda estiver fazendo, aqui vai um procedure para ler um número real sem erros:

    program LER_NUMEROS;
    uses
    crt;

    var
    x:real;

    procedure LerReal (var numeroreal:real);
    const
    menos=['-'];
    algarismos=['0'..'9'];
    ponto=['.',','];
    backspace=[chr(8)];
    enter=[chr(13)];
    var
    tecla:char;
    caracter: array[1..255] of char;
    numerostr:string;
    contador,i1:byte;
    erroconv:integer;
    aceitar:set of chr(0)..chr(255);
    begin
    contador:=1;
    aceitar:=['-','0'..'9','.',',',chr(13),chr(8)];
    repeat
    repeat
    tecla:=readkey
    until (tecla in aceitar) and ((contador=1) or (tecla<>'-')) and ((contador<>1) or (not (tecla in enter))); //aceitar apenas numeros, negativo, ponto, virgula, backspace e enter
    if tecla in algarismos+menos then //numero
    begin
    caracter[contador]:=tecla;
    write(tecla);
    if tecla in menos then
    aceitar:=aceitar-['-']; // nao aceitar o menos outra vez
    end
    else
    if tecla in ponto then //ponto ou virgula
    begin
    caracter[contador]:='.';
    write('.');
    aceitar:=aceitar-['.',',']; // nao aceitar mais o ponto
    end
    else
    if tecla in backspace then //backspace
    begin
    if contador>1 then
    begin
    if contador =2 then
    aceitar:=aceitar+['-'];
    if caracter[contador-1] in ponto then
    aceitar:=aceitar+['.'];
    caracter[contador-1]:='0';
    gotoxy(wherex-1,wherey);
    clreol;
    contador:=contador-2;
    end;
    end;
    contador:=contador+1;
    until (tecla in enter) or (contador=255); //enter
    numerostr:='';
    for i1:=1 to contador-2 do
    numerostr:=concat(numerostr,caracter[i1]); //unir caracteres
    val(numerostr,numeroreal,erroconv);
    writeln;
    end;

    begin {programa}
    textbackground(9);
    clrscr;
    textcolor(yellow);
    while true do
    begin
    writeln('Digite o numero:');
    LerReal(x);
    writeln('voce digitou o numero ',x:0:10,' .');
    readkey;
    clrscr;
    end;
    end.

    Compartilhar este post


    Link para o post
    Compartilhar em outros sites

    Crie uma conta ou entre para comentar

    Você precisar ser um membro para fazer um comentário






    Sobre o Clube do Hardware

    No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

    Direitos autorais

    Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

    ×