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

crixalves

Paint em Pascal

2 mensagens neste tópico

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.

:hmm:

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

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:)

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

Crie uma conta ou ligue-se para comentar

Só membros podem comentar

Criar nova conta

Registe para ter uma conta na nossa comunidade. É fácil!


Registar nova conta

Entra

Já tem conta? Inicie sessão aqui.


Entrar Agora