Advertisement
jacknpoe

Maperscaper (UPrincipal)

Nov 11th, 2013
178
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Delphi 7.67 KB | None | 0 0
  1. unit UPrincipal;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, ExtCtrls, Buttons, ComCtrls, Tabnotbk, UVisualizar, Spin;
  8.  
  9. type
  10.   TFPrincipal = class(TForm)
  11.     Image1: TImage;
  12.     Bevel1: TBevel;
  13.     Image2: TImage;
  14.     Bevel2: TBevel;
  15.     Label1: TLabel;
  16.     Label2: TLabel;
  17.     bbAbrir: TBitBtn;
  18.     OpenDialog1: TOpenDialog;
  19.     rgImpressora: TRadioGroup;
  20.     cbResolucao: TComboBox;
  21.     GroupBox1: TGroupBox;
  22.     LabelLarg: TLabel;
  23.     lLargura: TLabel;
  24.     lAltura: TLabel;
  25.     LabelAlt: TLabel;
  26.     lTamanho: TLabel;
  27.     LabelTam: TLabel;
  28.     LabelBytes: TLabel;
  29.     Bevel4: TBevel;
  30.     Bevel5: TBevel;
  31.     Bevel6: TBevel;
  32.     Image3: TImage;
  33.     Image4: TImage;
  34.     bver: TButton;
  35.     bverori: TButton;
  36.     chkDifuso: TCheckBox;
  37.     GroupBox2: TGroupBox;
  38.     GroupBox3: TGroupBox;
  39.     cbQuebra: TComboBox;
  40.     chkEscA180: TCheckBox;
  41.     GroupBox4: TGroupBox;
  42.     GroupBox5: TGroupBox;
  43.     sePontos: TSpinEdit;
  44.     Label3: TLabel;
  45.     eNome: TEdit;
  46.     bbProcurar: TBitBtn;
  47.     Label4: TLabel;
  48.     sPonto: TShape;
  49.     SaveDialog1: TSaveDialog;
  50.     bbGerar: TBitBtn;
  51.     bbSair: TBitBtn;
  52.     Label5: TLabel;
  53.     procedure bbAbrirClick(Sender: TObject);
  54.     procedure bverClick(Sender: TObject);
  55.     procedure bveroriClick(Sender: TObject);
  56.     procedure chkDifusoClick(Sender: TObject);
  57.     procedure Converte;
  58.     procedure bbSairClick(Sender: TObject);
  59.     procedure FormCreate(Sender: TObject);
  60.     procedure cbResolucaoChange(Sender: TObject);
  61.     procedure bbProcurarClick(Sender: TObject);
  62.     procedure bbGerarClick(Sender: TObject);
  63.   private
  64.     Arquivo: file;
  65.   public
  66.     { Public declarations }
  67.   end;
  68.  
  69. const
  70.   esc0 = #27+'K';
  71.   esc1 = #27+'L';
  72.   esc2 = #27+'Y';
  73.   esc3 = #27+'Z';
  74.  
  75.   esc4 = #27+'A'+#180;
  76.  
  77.   esc5 = #10;
  78.   esc6 = #13;
  79.   esc7 = #13#10;
  80.   esc8 = #13#27+'J'+#15;
  81.  
  82. var
  83.   FPrincipal: TFPrincipal;
  84.  
  85. implementation
  86.  
  87. {$R *.DFM}
  88.  
  89. procedure TFPrincipal.bbAbrirClick(Sender: TObject);
  90. var
  91.   xy: real;
  92.   y_8: integer;
  93. begin
  94.   if OpenDialog1.Execute then begin try
  95.     LabelLarg.Enabled := false;
  96.     lLargura.Enabled := false;
  97.     lAltura.Enabled := false;
  98.     LabelAlt.Enabled := false;
  99.     lTamanho.Enabled := false;
  100.     LabelTam.Enabled := false;
  101.     LabelBytes.Enabled := false;
  102.     chkDifuso.Enabled := false;
  103.     rgImpressora.Enabled := false;
  104.     cbResolucao.Enabled := false;
  105.     bverori.Enabled := false;
  106.     bver.Enabled := false;
  107.     chkEscA180.Enabled := false;
  108.     sePontos.Enabled := false;
  109.     cbQuebra.Enabled := false;
  110.     eNome.Enabled := false;
  111.     bbProcurar.Enabled := false;
  112.     bbGerar.Enabled := false;
  113.     Image1.Visible := false;
  114.     Image2.Visible := false;
  115.     Image3.Visible := true;
  116.     Image4.Visible := true;
  117.     Image1.Picture.LoadFromFile( OpenDialog1.FileName);
  118.     Image2.Picture.LoadFromFile( OpenDialog1.FileName);
  119.   except
  120.     ShowMessage( 'Não foi possível abrir este arquivo!'); exit;
  121.   end; end else exit;
  122.  
  123.   Cursor := crHourGlass;
  124.  
  125.   Converte;
  126.  
  127.   LabelLarg.Enabled := true;
  128.   lLargura.Enabled := true;
  129.   lAltura.Enabled := true;
  130.   LabelAlt.Enabled := true;
  131.   lTamanho.Enabled := true;
  132.   LabelTam.Enabled := true;
  133.   LabelBytes.Enabled := true;
  134.   chkDifuso.Enabled := true;
  135.   rgImpressora.Enabled := true;
  136.   cbResolucao.Enabled := true;
  137.   bverori.Enabled := true;
  138.   bver.Enabled := true;
  139.   chkEscA180.Enabled := true;
  140.   sePontos.Enabled := true;
  141.   cbQuebra.Enabled := true;
  142.   eNome.Enabled := true;
  143.   bbProcurar.Enabled := true;
  144.   bbGerar.Enabled := true;
  145.  
  146.   lLargura.Caption := inttostr(image2.picture.Width);
  147.   lAltura.Caption := inttostr(image2.picture.Height);
  148.  
  149.   y_8 := image2.picture.Height div 8;
  150.   if image2.picture.Height mod 8 > 1 then inc(y_8);
  151.   lTamanho.Caption := inttostr(image2.picture.Width*y_8);
  152.  
  153.   if image1.picture.height = 0 then begin
  154.     ShowMessage( 'Erro:'+chr(13)+'Bitmap com altura zero!'); Cursor := crDefault; exit; end;
  155.   xy := image1.picture.Width / image1.picture.Height;
  156.   if xy > 2 then begin
  157.     image1.Left := 9;
  158.     image1.Height := trunc (400 / xy);
  159.     image1.Top := trunc ((200-image1.height)/2)+24;
  160.     image1.Width := 400;
  161.     image2.Left := 9;
  162.     image2.Height := trunc (400 / xy);
  163.     image2.Top := trunc ((200-image2.height)/2)+248;
  164.     image2.Width := 400;
  165.   end else begin
  166.     image1.Top := 24;
  167.     image1.Width := trunc (200 * xy);
  168.     image1.Left := trunc ((400-image1.width)/2)+9;
  169.     image1.Height := 200;
  170.     image2.Top := 248;
  171.     image2.Width := trunc (200 * xy);
  172.     image2.Left := trunc ((400-image2.width)/2)+9;
  173.     image2.Height := 200;
  174.   end;
  175.   Image3.Visible := false;
  176.   Image4.Visible := false;
  177.   Image1.Visible := true;
  178.   Image2.Visible := true;
  179.   Cursor := crDefault;
  180. end;
  181.  
  182. procedure TFPrincipal.bverClick(Sender: TObject);
  183. begin
  184.   FVisualiza.Image1.Picture := Image2.Picture;
  185.   FVisualiza.ShowModal;
  186. end;
  187.  
  188. procedure TFPrincipal.bveroriClick(Sender: TObject);
  189. begin
  190.   FVisualiza.Image1.Picture := Image1.Picture;
  191.   FVisualiza.ShowModal;
  192. end;
  193.  
  194. procedure TFPrincipal.chkDifusoClick(Sender: TObject);
  195. begin
  196.   Cursor := crHourGlass;
  197.   Converte;
  198.   Cursor := crDefault;
  199. end;
  200.  
  201. procedure TFPrincipal.Converte;
  202. var
  203.   xtemp, ytemp, x2temp, cor_temp, rtemp1, rtemp2, rtemp3, rtemp4: integer;
  204.   linha: PByteArray;
  205. begin
  206.   try
  207.     rtemp1 := 32; rtemp2 := 96; rtemp3 := 160; rtemp4 := 224;
  208.     Image2.Picture := Image1.Picture;
  209.     Image2.Picture.Bitmap.PixelFormat := pf24bit;
  210.     for ytemp := 0 to image2.picture.Height-1 do begin
  211.       linha := Image2.Picture.Bitmap.ScanLine[ ytemp];
  212.       for xtemp := 0 to image2.picture.Width-1 do begin
  213.         cor_temp := (linha[xtemp*3]*2+linha[xtemp*3+1]*6+linha[xtemp*3+2]*2) div 10;
  214.         if chkDifuso.Checked then begin rtemp1 := random( 58) + 6; rtemp2 := random(64) + 64;
  215.           rtemp3 := random(64) + 128; rtemp4 := random(56) + 192; end;
  216.         for x2temp := 0 to 2 do
  217.           if ytemp mod 2 = 1 then
  218.             if (xtemp mod 2 + (ytemp div 2) mod 2) = 1 then
  219.               if cor_temp > rtemp1 then linha[ xtemp*3+x2temp] := 255 else linha[ xtemp*3+x2temp] := 64
  220.             else
  221.               if cor_temp > rtemp3 then linha[ xtemp*3+x2temp] := 255 else linha[ xtemp*3+x2temp] := 64
  222.           else
  223.             if (xtemp mod 2 + (ytemp div 2) mod 2) = 1 then
  224.               if cor_temp > rtemp4 then linha[ xtemp*3+x2temp] := 255 else linha[ xtemp*3+x2temp] := 64
  225.             else
  226.               if cor_temp > rtemp2 then linha[ xtemp*3+x2temp] := 255 else linha[ xtemp*3+x2temp] := 64
  227.   end; end; except
  228.     ShowMessage( 'Não foi possível converter este Bitmap em monocromático!'); Cursor := crDefault; exit; end;
  229. end;
  230.  
  231. procedure TFPrincipal.bbSairClick(Sender: TObject);
  232. begin
  233.   close;
  234. end;
  235.  
  236. procedure TFPrincipal.FormCreate(Sender: TObject);
  237. begin
  238.   cbResolucao.ItemIndex := 2;
  239.   cbQuebra.ItemIndex := 3;
  240. end;
  241.  
  242. procedure TFPrincipal.cbResolucaoChange(Sender: TObject);
  243. begin
  244.   case cbResolucao.ItemIndex of
  245.     0:    SPonto.Width := 60;
  246.     1..2: SPonto.Width := 30;
  247.     3:    SPonto.Width := 15;
  248.   else
  249.     SPonto.Width := 0;
  250.   end;
  251. end;
  252.  
  253. procedure TFPrincipal.bbProcurarClick(Sender: TObject);
  254. begin
  255.   if SaveDialog1.Execute then eNome.Text := SaveDialog1.FileName;
  256. end;
  257.  
  258. procedure TFPrincipal.bbGerarClick(Sender: TObject);
  259. begin
  260.   if eNome.Text = '' then begin ShowMessage( 'Escolha um nome para o arquivo a gerar!'); exit; end;
  261.   AssignFile( Arquivo, eNome.Text);
  262.   Rewrite( Arquivo, 1);
  263.  
  264.   if chkEscA180.Checked then BlockWrite( Arquivo, esc4, 3);
  265.  
  266. { esc0 = #27+'K';
  267.   esc1 = #27+'L';
  268.   esc2 = #27+'Y';
  269.   esc3 = #27+'Z';
  270.  
  271.   esc4 = #27+'A'+#180;
  272.  
  273.   esc5 = #10;
  274.   esc6 = #13;
  275.   esc7 = #13#10;
  276.   esc8 = #13#27+'J'+#15; }
  277. end;
  278.  
  279. end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement