Jump to content
  • Revista PROGRAMAR: Já está disponível a edição #60 da revista programar. Faz já o download aqui!

Sign in to follow this  
crixalves

Paint em Pascal

Recommended Posts

crixalves

ola,

Tenho aqui um projecto criado por mim. Para programação tive de fazer um projecto em 2 semanas, digam o que acham.

P.S: o programa foi realizado em Turbo pascal, é necessário a TPU que colocarei no fim com o nome de GRF e só corre nao corre no Vista.

program minipait;
uses crt,graph,grf;
type linhas=record
     x1,y1,cor1,tipo,raio,x2,y2:integer;
     tx:string;
end;
var
   f:linhas;
   fx,fx2:file of linhas;
   i,j,x,y,cor,a,r,c,q,h,c1,m,entrar:integer;
   d:char;
   l,t,v:string;

procedure de;
begin
     graficos;
     settextstyle(4,0,7);
     outtextxy(100,20,'Cristiano Alves');
     settextstyle(0,0,7);
     setcolor(red);
     outtextxy(80,380,'Minipaint');
     tecla(220,100,420,150,false);
     settextstyle(5,0,7);
     setcolor(white);
     outtextxy(250,70,'Novo');
     tecla(220,200,420,250,false);
     setcolor(white);
     outtextxy(250,170,'Abrir');
     tecla(220,300,420,350,false);
     setcolor(white);
     outtextxy(260,270,'Sair');
     rato;
end;
procedure botoes;
begin
     outtextxy(560,50,'Cores:');
     setcolor(1);
     rectangle(560,70,580,90);{cor azul}
     setfillstyle(1,blue);
     floodfill(561,71,1);
     setcolor(2);
     rectangle(600,70,620,90); {cor verde}
     setfillstyle(1,2);
     floodfill(601,71,2);
     setcolor(3);
     rectangle(560,100,580,120);
     setfillstyle(1,3);
     floodfill(561,101,3);
     setcolor(4);
     rectangle(600,100,620,120);
     setfillstyle(1,4);
     floodfill(601,101,4);
     setcolor(5);
     rectangle(560,130,580,150);
     setfillstyle(1,5);
     floodfill(561,131,5);
     setcolor(6);
     rectangle(600,130,620,150);
     setfillstyle(1,6);
     floodfill(601,131,6);
     setcolor(7);
     rectangle(560,160,580,180);
     setfillstyle(1,7);
     floodfill(561,161,7);
     setcolor(8);
     rectangle(600,160,620,180);
     setfillstyle(1,8);
     floodfill(601,161,8);
     setcolor(9);
     rectangle(560,190,580,210);
     setfillstyle(1,9);
     floodfill(561,191,9);
     setcolor(10);
     rectangle(600,190,620,210);
     setfillstyle(1,10);
     floodfill(601,191,10);
     setcolor(11);
     rectangle(560,220,580,240);
     setfillstyle(1,11);
     floodfill(561,221,11);
     setcolor(12);
     rectangle(600,220,620,240);
     setfillstyle(1,12);
     floodfill(601,221,12);
     setcolor(13);
     rectangle(560,250,580,270);
     setfillstyle(1,13);
     floodfill(561,251,13);
     setcolor(14);
     rectangle(600,250,620,270);
     setfillstyle(1,14);
     floodfill(601,251,14);
     setcolor(15);
     rectangle(560,280,580,300);
     setfillstyle(1,15);
     floodfill(561,281,15);
     setcolor(15);
     rectangle(600,280,620,300); {fim de rectangulos das cores}
     setfillstyle(1,16);
     floodfill(601,281,15);
     setcolor(red);
     outtextxy(548,310,'Ferramentas');
     circle(570,330,10);
     rectangle(600,320,620,340);
     line(560,350,580,370);
     outtextxy(600,350,'Abc');
     rectangle(560,390,570,400);
     setfillstyle(1,red);
     floodfill(561,391,red);
     setcolor(1);
     rectangle(571,390,580,400);
     setfillstyle(1,1);
     floodfill(572,391,1);


end;
procedure menus(nome:integer);
begin
     inicrato;
     jan2(0,0,640,40,1,1,white,5);{janela de texto}
     if(nome=1)then
     begin
          jan2(0,40,540,480,1,1,white,5);{janela de tela}
     end;
     jan2(540,40,640,480,1,1,black,5); {janela de ferramentas}
     jan2(0,450,540,480,1,1,white,5);
     setcolor(red);
     outtextxy(10,460,'Ajuda');
     outtextxy(150,15,'Mini Paint By Cristiano Alves 11§IF'); {texto}
     botoes;
     tecla(620,0,640,20,true);
     setcolor(black);
end;
procedure dc; {desenhar circulos}
var
   xi,yi:integer;
begin
     escrato;
     rato;
     setcolor(black);
     outtextxy(55,460,'Tecla esquerda do rato para centro. Tecla direita para Raio.');
     repeat
           ratopos(x,y);
     until(ratotec=1)and(x<535)and(x>5)and(y>45)and(y<445) ;
     xi:=x; {x centro}
     yi:=y; {y centro}
     x:=600;
     y:=30;
     repeat
           ratopos(x,y);
     until(ratotec=2)and(x<535)and(x>5)and(y>45)and(y<445);
     setcolor(white);
     outtextxy(55,460,'Tecla esquerda do rato para centro. Tecla direita para Raio.');
     x:=(x-xi)+(y-yi);
     setcolor(c1);
     escrato;
     circle(xi,yi,x);
     menus(0);
     f.raio:=x;
     f.y1:=yi;
     f.x1:=xi;
     f.tipo:=2;                   {falta formula}
     if(c1=0)then
     begin
          f.cor1:=16;
     end
     else
     begin
          f.cor1:=c1;
     end;
     seek(fx,filesize(fx));
     write(fx,f);
     rato;
     end;
procedure dr; {desenhar rectangulos}
var
   xi,yi:integer;
begin
     setcolor(black);
     outtextxy(55,460,'Tecla esquerda do rato para canto1. Tecla direita para cato2.');
     repeat
           ratopos(x,y);
     until(ratotec=1)and(x<535)and(x>5)and(y>45)and(y<445);
     xi:=x; {x inicial}
     yi:=y; {y inicial}
     x:=600;
     y:=30;
     repeat
           ratopos(x,y);
     until(ratotec=2)and(x<535)and(x>5)and(y>45)and(y<445);
     setcolor(white);
     outtextxy(55,460,'Tecla esquerda do rato para canto1. Tecla direita para cato2.');
     escrato;
     setcolor(c1);
     rectangle(xi,yi,x,y);
     if(c1=0)then
     begin
          f.cor1:=16;
     end
     else
     begin
          f.cor1:=c1;
     end;
     f.tipo:=3;
     f.x1:=xi;
     f.x2:=x;
     f.y1:=yi;
     f.y2:=y;
     seek(fx,filesize(fx));
     write(fx,f);

     rato;
end;
procedure dl;
var
   xi,yi:integer;
begin
     setcolor(black);
     outtextxy(55,460,'Tecla esquerda do rato para inicio. Tecla direita para fim.');
     repeat
           ratopos(x,y);
     until(ratotec=1)and(x<535)and(x>5)and(y>45)and(y<445);
     xi:=x; {x inicial}
     yi:=y; {y inicial}
     x:=600;
     y:=30;
     repeat
           ratopos(x,y);
     until(ratotec=2)and(x<535)and(x>5)and(y>45)and(y<445);
     setcolor(white);
     outtextxy(55,460,'Tecla esquerda do rato para inicio. Tecla direita para fim.');
     escrato;
     setcolor(c1);
     line(xi,yi,x,y);
     rato;
     if(c1=0)then
     begin
          f.cor1:=16;
     end
     else
     begin
          f.cor1:=c1;
     end;
     f.tipo:=4;
     f.x1:=xi;
     f.x2:=x;
     f.y1:=yi;
     f.y2:=y;
     seek(fx,filesize(fx));
     write(fx,f);
end;
procedure dt;
begin
     setcolor(black);
     outtextxy(55,460,'Clique onde quer inserir o texto');
     repeat
           ratopos(x,y);
     until(ratotec=1)and(x<535)and(x>5)and(y>45)and(y<445);
     setcolor(white);
     outtextxy(55,460,'Clique onde quer inserir o texto');
     escrato;
     t:=lermg(0,x,y,c1,white);
     f.tipo:=5;
     rato;
     f.tx:=t;
     f.x1:=x;
     f.y1:=y;
     f.cor1:=c1;
     seek(fx,filesize(fx));
     write(fx,f);
end;

procedure comandos;
begin
     r:=40;
     c:=0;
     for j:= 1 to 8 do
     begin
          q:=560;
          r:=r+30;
          for h:= 1 to 2 do
          begin
               c:=c+1;
               if(x>q)and(x<q+20)and(y>r)and(y<r+20)then
               begin
                    c1:=c;
                    setcolor(black);
                    outtextxy(55,460,'Escolheu uma cor');
                    delay(10000);
                    delay(10000);
                    delay(10000);
                    delay(10000);
                    setcolor(white);
                    outtextxy(55,460,'Escolheu uma cor');
               end;
               q:=q+40;
          end;
     end;
     ratopos(x,y);
     if(detecta(560,310,580,330))then
     begin
          dc;
     end;
     if(detecta(600,320,620,340))then
     begin
          dr;
     end;
     if(detecta(560,350,580,370))then
     begin
          dl;
     end;
     if(detecta(600,350,620,370))then
     begin
          dt;
     end;
     if(detecta(560,390,580,400))then
     begin
          repeat
                ratopos(x,y);
                setcolor(16);
                outtextxy(55,460,'Tecla esquerda para sair do modo borracha');
                if(ratotec=1)and(x<505)and(x>5)and(y>45)and(y<415)then
                begin
                     ratopos(x,y);
                     setcolor(16);
                     rectangle(x,y,x+30,y+30);
                     setcolor(15);
                     rectangle(x,y,x+30,y+30);
                     for i:=x+1 to x+28 do
                     begin
                          for j:=y+1 to y+28 do
                              putpixel(i,j,white);
                     end;
                     seek(fx,filesize(fx));
                     f.x1:=x;
                     f.y1:=y;
                     f.x2:=x+30;
                     f.y2:=y+30;
                     f.tipo:=6;
                     write(fx,f);
                end;
          until(ratotec=2);
          setcolor(15);
          outtextxy(55,460,'Tecla esquerda para sair do modo borracha');
     end;
end;
procedure carregar;
begin
     graficos;
     menus(1);
     setcolor(16);
     outtextxy(55,460,'A carregar imagem');
     while not eof(fx)do
     begin
          read(fx,f);
          if(f.tipo=1)then
          begin
               putpixel(f.x1,f.y1,f.cor1);
          end
          else
          begin
               if(f.tipo=2)then
               begin
                    setcolor(f.cor1);
                    circle(f.x1,f.y1,f.raio);
               end
               else
               begin
                    if(f.tipo=3)then
                    begin
                         setcolor(f.cor1);
                         rectangle(f.x1,f.y1,f.x2,f.y2);
                    end
                    else
                    begin
                         if(f.tipo=4)then
                         begin
                              setcolor(f.cor1);
                              line(f.x1,f.y1,f.x2,f.y2);
                         end
                         else
                         begin
                              if(f.tipo=5)then
                              begin
                                   setcolor(f.cor1);
                                   outtextxy(f.x1,f.y1,f.tx);
                              end
                              else
                              begin
                                   if(f.tipo=6)then
                                   begin
                                        setcolor(15);
                                        rectangle(f.x1,f.y1,f.x2,f.y2);
                                        for i:=f.x1+1 to f.x1+28 do
                                        begin
                                             for j:=f.y1+1 to f.y1+28 do
                                             begin
                                                  putpixel(i,j,white);
                                             end;
                                        end;
                                   end;
                              end;
                         end;
                    end;
               end;
          end;
     end;
     menus(0);
end;
procedure vmenu;
begin
     escrato;
     cleardevice;
     delay(10000);
     delay(10000);
     delay(10000);
     delay(10000);
     delay(10000);
     delay(10000);
     jan2(200,200,400,300,1,1,white,5);
     outtextxy(210,210,'Voltar ao menu ou sair?');
     tecla(210,240,290,270,false);
     outtextxy(230,250,'Menu');
     tecla(310,240,390,270,false);
     outtextxy(330,250,'Sair');
     rato;
     repeat
          entrar:=0;
          if(ratotec=1)then
          begin
               if(detecta(210,240,290,270))then
               begin
                    tecla(210,240,290,270,true);
                    delay(10000);
                    delay(10000);
                    delay(10000);
                    tecla(210,240,290,270,false);
                    outtextxy(230,250,'Menu');
                    entrar:=1;
                    d:=' ';
                    a:=1;
                    de;
               end
               else
               begin
                    if(detecta(310,240,390,270))then
                    begin
                         tecla(310,240,390,270,false);
                         delay(10000);
                         delay(10000);
                         delay(10000);
                         tecla(310,240,390,270,true);
                         d:='3';
                         a:=1;
                         entrar:=1;
                    end;
               end;
          end;
     until(entrar=1);
end;

procedure desenho;
var
   s,entrou:integer;
begin

     if(m<>1)then      {para nÆo apagar}
     begin
          rewrite(fx);
          close(fx);
          reset(fx);
     end;
     s:=0;
     rato;
     a:=0;
     repeat
           ratopos(x,y);
           if(ratotec=1)then  {desenhar}
           begin
                if(x>540)then
                begin
                     comandos;
                end;
                if detecta(620,0,640,20) then
                begin
                     tecla(620,0,640,20,false);
                     setcolor(black);
                     outtextxy(55,460,'Sair?');
                     delay(10000);
                     delay(10000);
                     delay(10000);
                     delay(10000);
                     setcolor(white);
                     outtextxy(55,460,'Sair?');
                     tecla(620,0,640,20,true);
                     jan2(200,200,400,300,1,1,white,5);
                     setcolor(red);
                     outtextxy(210,210,'Deseja guardar?');
                     tecla(220,240,260,270,false);
                     setcolor(red);
                     outtextxy(230,250,'Sim');      {botao sim }
                     tecla(270,240,310,270,false);
                     setcolor(red);
                     outtextxy(280,250,'Nao');     {botao nao}
                     tecla(320,240,390,270,false);
                     setcolor(red);
                     outtextxy(325,250,'Cancelar');
                     ratopos(x,y);                 {botao cancelar}
                     rato;
                     entrou:=0;
                     repeat
                           if(ratotec=1)then
                           begin
                                if(detecta(220,240,260,270))then {save do ficheiro}
                                begin
                                    entrou:=1;
                                    escrato;
                                    tecla(220,240,260,270,true);
                                    delay(10000);
                                    delay(10000);
                                    tecla(220,240,260,270,false);
                                    setcolor(red);
                                    outtextxy(230,250,'Sim');
                                    jan2(200,200,400,300,1,1,white,5);
                                    rato;
                                    outtextxy(210,210,'Indique o endere‡o:');
                                    l:=lerl(240,260,30,white,red,12,' ');
                                    l:=l+'.cri';
                                    assign(fx2,l);
                                    close(fx);
                                    reset(fx);
                                    rewrite(fx2);
                                    while not eof(fx) do
                                    begin
                                         seek(fx2,filesize(fx2));
                                         read(fx,f);
                                         write(fx2,f);
                                    end;
                                    close(fx2);
                                    vmenu;
                               end
                               else
                               begin
                                    if(detecta(270,240,310,270))then {sair}
                                    begin
                                         entrou:=1;
                                         tecla(270,240,310,270,true);
                                         delay(10000);
                                         delay(10000);
                                         tecla(270,240,310,270,false);
                                         setcolor(red);
                                         outtextxy(280,250,'Nao');
                                         vmenu;
                                    end
                                    else
                                    begin
                                         if(detecta(320,240,390,270))then    {cancelar}
                                         begin

                                              entrou:=1;
                                              escrato;
                                              cleardevice;
                                              menus(1);
                                              setcolor(16);
                                              outtextxy(55,460,'A carregar imagem');
                                              close(fx);
                                              reset(fx);
                                              carregar;
                                              menus(0);
                                              setcolor(15);
                                              outtextxy(55,460,'A carregar imagem');
                                              rato;
                                         end;
                                    end;
                              end;
                          end;
                     until(entrou=1);
                end;
                if(x<535)and(x>5)and(y>45)and(y<445)then
                begin
                     escrato;
                     seek(fx,filesize(fx));
                     putpixel(x,y,c1);
                     f.tipo:=1;
                     f.x1:=x;
                     f.y1:=y;
                     if(c1=0)then
                     begin
                          f.cor1:=16;
                     end
                     else
                     begin
                          f.cor1:=c1;
                     end;
                end;
                s:=1;
                write(fx,f);
                rato;
           end;
     until(a=1);
     close(fx);
end;
procedure abrir;
var
   existe:integer;
   z:string;
begin
     graficos;
     jan2(200,200,400,300,1,1,white,5);
     rato;
     outtextxy(210,210,'Indique o endere‡o:');
     z:=lerl(240,260,30,white,red,12,' ');
     z:=z+'.cri';
     {$i-}
     assign(fx2,z);
     reset(fx2);
     close(fx2);
     {$i+}
     existe:=ioresult;
     if(existe<>0)then
     begin
          cleardevice;
          jan2(200,200,400,300,1,1,white,5);
          outtextxy(210,210,'O ficheiro nÆo exite');
          tecla(210,240,290,270,false);
          outtextxy(230,250,'Abrir');
          tecla(310,240,390,270,false);
          outtextxy(330,250,'Sair');
          repeat
                entrar:=0;
                if(ratotec=1)then
                begin
                     if(detecta(210,240,290,270))then
                     begin
                          tecla(210,240,290,270,true);
                          delay(10000);
                          delay(10000);
                          delay(10000);
                          tecla(210,240,290,270,false);
                          entrar:=1;
                     end
                     else
                     begin
                          if(detecta(310,240,390,270))then
                          begin
                               entrar:=1;
                               tecla(310,240,390,270,true);
                               delay(10000);
                               delay(10000);
                               delay(10000);
                               tecla(310,240,390,270,false);
                               vmenu;
                          end;
                     end;
                end;
          until(entrar=1);
     end
     else
     begin
          reset(fx2);
          rewrite(fx);
          while not eof(fx2)do
          begin
               read(fx2,f);
               seek(fx,filesize(fx));
               write(fx,f);
          end;
          close(fx);
          reset(fx);
          carregar;
          m:=1;
          rato;
          desenho;
     end;
     m:=0;
end;
begin
      assign(fx,'tmp.dat');
      de;
      repeat
             if(ratotec=1)then
             begin
                  if(detecta(220,100,420,150))then
                  begin
                       tecla(220,100,420,150,false);
                       delay(10000);
                       delay(10000);
                       delay(10000);
                       tecla(220,100,420,150,true);
                       d:='1';
                  end
                  else
                  begin
                       if(detecta(220,200,420,250))then
                       begin
                            tecla(220,200,420,250,false);
                            delay(10000);
                            delay(10000);
                            delay(10000);
                            tecla(220,200,420,250,true);
                            d:='2';
                       end
                       else
                       begin
                            if(detecta(220,300,420,350))then
                            begin
                                 tecla(220,300,420,350,true);
                                 delay(10000);
                                 delay(10000);
                                 delay(10000);
                                 tecla(220,300,420,350,false);
                                 d:='3';
                            end;
                       end;
                  end;
             end;
             rewrite(fx);
             close(fx);
             case d of
                 '1':begin
                          graficos;
                          menus(1);
                          desenho;
                 end;
                 '2':begin
                          closegraph;
                          abrir;
                 end;
            end;
      until(d='3');
end.

A tpu GRf esta aqui:

        { Esta unit contem procedimentos e fun‡”es gr ficas que permitem fazer alguns
  efeitos no cenario o que torna o ambiente do programa mais agrad vel . }


Unit GRF;
interface
Uses crt,graph,dos;

Procedure graficos;
Procedure Aim(xi,yi,xf,yf:integer;var p:pointer;var t:word);
Procedure Jan(xi,yi,xf,yf,cor1,cor2,cor,gro:integer;var p:pointer;var t:word);
Procedure Jan2(xi,yi,xf,yf,cor1,cor2,cor,gro:integer);
Procedure Jan3(xi,yi,xf,yf,cor1,cor2,gro:integer);
Function Lerl(x,y,t,cora,corl,tam:integer;ch:char):string;
Procedure Escreve(x,y,cor:integer;s:string);
Procedure Imagem(x,y:integer;s:string);
Procedure Gravarim(x,y,xf,yf:integer;st:string);
Procedure Inicrato;
Procedure Rato;
Procedure Ratopos(var x,y:integer);
Function Ratotec:integer;
Procedure Escrato;
Procedure Definir(xi,yi,xf,yf:integer);
Function Verrato:boolean;
Procedure Ratocoord(x,y:integer);
Function Detecta(xi,yi,xf,yf:integer):boolean;
Procedure Tecla(xi,yi,xf,yf:integer;estado:boolean);
Procedure Pintar(x,y,cor,corl:integer);
Procedure Marca(xi,yi,xf,yf:integer;est:boolean);
Function Lermg(inc,x,y:integer;cor,corf:integer):string;

Implementation

{ Lˆ uma string em modo de texto.
     Sintaxe :
     String:=lermg(espaco entre letras,posi‡Æo y,posi‡Æo x, cor do texto, cor do fundo);

                          se espaco entre letras = 0, calcula autom ticamente
}

Function lermg(inc,x,y:integer;cor,corf:integer):string;
var
   texto:string;
   k,ant:char;
   p,i:integer;
   modotexto:TextSettingsType;
begin
     p:=1;
     setcolor(cor);
     if inc=0 then
     begin
          gettextsettings(modotexto);
          inc:=modotexto.CharSize;
          inc:=inc*4+5;
     end;
     repeat
           outtextxy(x,y,'');
           k:=readkey;
           if (k<>#13) AND (k<>#27) then
           begin
              if (k=#8) then
              begin
                if (p>1) then
                begin
                     setcolor(corf);
                     x:=x-inc;
                     p:=p-1;
                     outtextxy(x,y,texto[p]);
                     delete(texto,p,1);
                     setcolor(cor);
                end
                else
                    write(#7);
              end
              else
              begin
                outtextxy(x,y,k);
                insert(k,texto,p);
                p:=p+1;
                x:=x+inc;
           end;
          end;
     until (k=#13) or (k=#27);
     lermg:=copy(texto,1,p-1);
end;




{ *** INICIALIZA O MODO GRAFICO (SIMPLES MAS UTIL) *** }
{ Syntax : Ig ( driver gr fico , modo gr fico ) }

Procedure graficos;
Var
   Gd,Gm,Erro:integer;
Begin
     Gd:=detect;
     InitGraph(Gd,gm,'C:\tp\bgi');
     Erro:=GraphResult;
     If erro<>grok then
        Writeln(erro);
end;


{ *** SINTETIZA TUDO O QUE O GETIMAGE PRECISA NUM SO PROCEDIMENTO *** }
{ Syntax : Aim ( xi , yi , xf , yf , apontador , tamanho ) }

Procedure Aim(xi,yi,xf,yf:integer;var p:pointer;var t:word);
Begin
     t:=imagesize(xi,yi,xf,yf);getmem(p,t);
     getimage(xi,yi,xf,yf,p^)
end;

{ *** ELABORA UMA JANELA E (APANHA) A PARTE DA IMAGEM NA QUAL ESSA *** }
{ ***                        JANELA VAI ASSENTAR                   *** }
{ Syntax : Jan ( xi , yi , xf , yf , rebordo 1 , rebordo 2 , fundo , grossura ,apontador , tamanho ) }

Procedure Jan(xi,yi,xf,yf,cor1,cor2,cor,gro:integer;var p:pointer;var t:word);
Var x:integer;
Begin
     aim(xi,yi,xf,yf,p,t);
     for x:=1 to gro do
      begin
       setcolor(cor1);
       line(xi+x,yi+x,xf-x,yi+x);Line(xf-x,yi+x,xf-x,yf-x);
       setcolor(cor2);
       line(xi+x,yi+x,xi+x,yf-x);Line(xi+x,yf-x,xf-x,yf-x)
      end;
     Setcolor(cor);
     for x:=yi+(gro+1) to yf-(gro+1) do
       line(xi+(gro+1),x,xf-(gro+1),x);
     setcolor(darkgray);
     rectangle(xi,yi,xf,yf)
end;

{ *** ELABORA UMA JANELA A MESMA JANELA MAS NAO GUARDA EM MEMORIA A *** }
{ ***               PARTE DA IMAGEM ONDE VAI ASSENTAR               *** }
{ Syntax : Jan2( xi , yi , xf , yf , rebordo 1 , rebordo 2 , fundo , grossura ) }

Procedure Jan2(xi,yi,xf,yf,cor1,cor2,cor,gro:integer);
Var x:integer;
Begin
     for x:=1 to gro do
      begin
       setcolor(cor1);
       line(xi+x,yi+x,xf-x,yi+x);Line(xf-x,yi+x,xf-x,yf-x);
       setcolor(cor2);
       line(xi+x,yi+x,xi+x,yf-x);Line(xi+x,yf-x,xf-x,yf-x)
      end;
     setcolor(cor);
     for x:=yi+(gro+1) to yf-(gro+1) do
       line(xi+(gro+1),x,xf-(gro+1),x);
     setcolor(darkgray);
     rectangle(xi,yi,xf,yf)
end;

{ *** ELABORA APENAS O REBORDO DE UMA JANELA DO TIPO ANTERIOR *** }
{ Syntax : Jan3 ( xi , yi , xf , yf , rebordo 1 , rebordo 2 , grossura ) }

Procedure Jan3(xi,yi,xf,yf,cor1,cor2,gro:integer);
Var x:integer;
Begin
     for x:=1 to gro do
      begin
       setcolor(cor1);
       line(xi+x,yi+x,xf-x,yi+x);Line(xf-x,yi+x,xf-x,yf-x);
       setcolor(cor2);
       line(xi+x,yi+x,xi+x,yf-x);Line(xi+x,yf-x,xf-x,yf-x)
      end;
     setcolor(darkgray);
     rectangle(xi,yi,xf,yf)
end;

{ *** TEM A MESMA FUN€ŽO QUE O READLN MAS  USADO EM MODO GRAFICO *** }
{     Syntax :                                                        }
{ string := Lerl (x,y,<tamanho da frase>,<cor de eliminacao>,         }
{                     <cor da letra>,<tamanho da fonte>,<cursor>);    }


Function Lerl(x,y,t,cora,corl,tam:integer;ch:char):string;
Type palavra=array[1..101]of char;

Procedure Ler(var car:char;var code:integer);
Var r:Registers;
Begin
     r.ah:=00;
     intr($16,r);
     car:=chr(r.al);
     code:=r.ah
end;

Procedure Apagarl(x,y,tam:integer);
Var u:integer;
Begin
     for u:=y to y+tam do
         begin
          setcolor(cora);
          line(x,u,x+tam,u)
         end;
     setcolor(corl)
end;

Var s:string;
    car:char;
    code,xm,ym,c:integer;
    p:palavra;

Begin
     for code:=1 to t do
       p[code]:=' ';
     xm:=x;ym:=y;c:=1;
     setcolor(corl);
     outtextxy(x,y,ch);
     repeat
           setcolor(corl);
           ler(car,code);car:=upcase(car);
           if car=chr(8) then
                          begin
                           if x>xm then
                                    begin
                                     apagarl(x,y,tam);
                                     x:=x-tam;c:=c-1;p[c]:=' ';
                                     apagarl(x,y,tam);
                                     outtextxy(x,y,ch)
                                    end
                          end
                         else
           if code=28 then
                         else
           if code=1 then
                         else
                             begin
                              if c=t+1 then else begin
                                                  apagarl(x,y,tam);
                                                  outtextxy(x,y,car+ch);
                                                  p[c]:=car
                                                 end;
                              if c>=t+1 then
                                         begin
                                          x:=xm+(t*tam);c:=t+1
                                         end
                                        else
                                         begin
                                          x:=x+tam;c:=c+1
                                         end;
                             end;
     until (code=28) or (code=1);
     s:='';apagarl(x,y,tam);
     if code=1 then
                lerl:='sai'
               else
                begin
                 for x:=1 to (c-1) do
                   s:=s+p[x];
                 lerl:=s
                end
end;

{ *** ESCREVE A FONTE ORIGINAL COM UM REBORDO *** }
{ Syntax : Escreve ( x , y , cor das letras , ' STRING ' ) }

Procedure Escreve(x,y,cor:integer;s:string);
Begin
     setcolor(darkgray);
     outtextxy(x-1,y,s);
     outtextxy(x+1,y,s);
     outtextxy(x,y-1,s);
     outtextxy(x,y+1,s);
     outtextxy(x-1,y-1,s);
     outtextxy(x+1,y-1,s);
     outtextxy(x-1,y+1,s);
     outtextxy(x+1,y+1,s);
     setcolor(cor);
     outtextxy(x,y,s)
end;

{ *** CARREGA UMA PARTE DA IMAGEM PARA UMA DETERMINADA POSICAO *** }
{ Syntax : Imagem ( x , y , ' NOME DA IMAGEM ' ) }

Procedure Imagem(x,y:integer;s:string);
Var p:pointer;
    t:word;
    f:file;

Begin
     if fsearch(s,getenv('Path'))<>'' then
     Begin
          assign(f,s);reset(f,1);
          t:=filesize(f);
          getmem(p,t);
          blockread(f,p^,t);
          close(f);
          putimage(x,y,p^,XORput);
          freemem(p,t);
     end;
end;

{ *** GRAVA UMA DETERMINADA PARTE DA IMAGEM PARA UM FICHEIRO *** }
{ Syntax : Gravarim ( xi , yi , xf , yf , ' NOME DA IMAGEM ' ) }

Procedure Gravarim(x,y,xf,yf:integer;st:string);
var p:pointer;
    t:word;
    f:file;
Begin
     aim(x,y,xf,yf,p,t);
     assign(f,st);rewrite(f,1);
     blockwrite(f,p^,t);
     close(f);
     freemem(p,t)
end;

{ *** INICIA O DRIVER DO RATO *** }
{ Syntax : Inicrato }

Procedure Inicrato;
Var r:Registers;
Begin
     r.ax:=00;
     intr($33,r)
end;

{ *** MOSTRA O RATO *** }
{ Syntax : Rato }

Procedure Rato;
Var r:Registers;
Begin
     r.ax:=01;
     Intr($33,r)
end;

{ *** INDICA A POSICAO DO RATO *** }
{ Syntax : Ratopos ( coordenada x , coordenada y ) }

Procedure Ratopos(var x,y:integer);
Var r:Registers;
Begin
     r.ax:=03;
     Intr($33,r);
     x:=R.cx;
     y:=R.dx
end;

{ *** INDICA A TECLA DO RATO QUE FOI PREMIDA : 0 - NENHUMA         *** }
{                                              1 - TECLA ESQUERDA      }
{                                              2 - TECLA DIREITA       }
{ Syntax : integer := Ratotec }

Function Ratotec:integer;
Var r:Registers;
Begin
     r.ax:=03;
     Intr($33,r);
     ratotec:=r.bx
end;

{ *** ESCONDE O RATO *** }
{ Syntax : Escrato }

Procedure Escrato;
Var r:Registers;
Begin
     r.ax:=02;
     intr($33,r)
end;

{ *** DEFINE UMA JANELA DE TRABALHO PARA O RATO *** }
{ Syntax : Definir ( xi , yi , xf , yf ) }

Procedure Definir(xi,yi,xf,yf:integer);
Var r:Registers;
Begin
     r.ax:=7;
     r.cx:=xi;
     r.dx:=xf;
     intr($33,r);
     r.ax:=8;
     r.cx:=yi;
     r.dx:=yf;
     intr($33,r)
end;

{ * VERIFICA A INSTALACAO DO RATO : TRUE - INSTALADO , FALSE - NAO INSTALADO * }
{ Syntax : boolean := Verrato }

Function Verrato:boolean;
Var r:Registers;
Begin
     verrato:=false;
     r.ax:=0;
     intr($33,r);
     if r.ax<>0 then verrato:=true
end;

{ *** COLOCA O CURSOR DO RATO NUMA DETERMINADA POSICAO *** }
{ Syntax : Ratocoord ( coordenada x , coordenada y ) }

Procedure Ratocoord(x,y:integer);
Var r:Registers;
Begin
     r.ax:=$4;
     r.cx:=x;
     r.dx:=y;
     intr($33,r)
end;

{ *** DETECTA A PRESENCA DO RATO NUMA DETERMINADA JANELA *** }
{ Syntax : boolean := Detecta( xi , yi , xf , yf ) }

Function Detecta(xi,yi,xf,yf:integer):boolean;
var x,y:integer;
Begin
     detecta:=false;ratopos(x,y);
     if (xi<x) and (xf>x) and (yi<y) and (yf>y) then detecta:=true
end;

{ *** ELABORA UMA TECLA *** }
{ Syntax : Tecla ( xi , yi , xf , yf , estado da tecla (true,false) ) }

Procedure Tecla(xi,yi,xf,yf:integer;estado:boolean);
Var cor1,cor2:integer;
Begin
     case estado of
      false:begin cor1:=white;cor2:=darkgray end;
      true:begin cor1:=darkgray;cor2:=white end
     end;
     setcolor(darkgray);
     rectangle(xi,yi,xf,yf);
     setfillstyle(1,lightgray);
     floodfill(xi+1,yi+1,darkgray);
     setcolor(cor1);
     line(xi+1,yi+1,xf-1,yi+1);
     line(xf-1,yi+1,xf-1,yf-1);
     setcolor(cor2);
     line(xi+1,yi+1,xi+1,yf-1);
     line(xi+1,yf-1,xf-1,yf-1)
end;

{ *** SINTETIZA O USO DO FLOODFILL *** }
{ Syntax : Pintar ( coordenada x , coordenada y , cor de pintura , cor limite ) }

Procedure Pintar(x,y,cor,corl:integer);
Begin
     setfillstyle(1,cor);
     floodfill(x,y,corl)
end;

{ *** FAZ O EFEITO DE PRESSŽO DA TECLA *** }
{ NOTA : Este procedimento funciona em conjunto com o procedimento tecla }
{ Syntax : Marca ( xi , yi , xf , yf , estado de marca ( true , false) }


Procedure Marca(xi,yi,xf,yf:integer;est:boolean);
Var p:pointer;
    t:word;
Begin
     escrato;
     aim(xi+2,yi+2,xf-2,yf-3,p,t);
     tecla (xi,yi,xf,yf,est);
     putimage(xi+3,yi+3,p^,normalput);
     while ratotec=1 do begin end;
     tecla(xi,yi,xf,yf,not est);
     putimage(xi+2,yi+2,p^,normalput);
     freemem(p,t);
     rato
end;

Begin
end.


Aguardo respostas.

🤔

Share this post


Link to post
Share on other sites
vasco16

neste momento estou a usar o windows vista.. quando tiver a possibilidade testo.. desde já os meus parabens fazer um programa desses em pascal.. é de homem:)

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
Sign in to follow this  

×

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.