[delphi-br] Código de barras sem componente

[Rodrigo Magno]

Gerar Código de Barras Ean13 


unit UnCriaCodBarras;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Printers;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    procedure GeraBarrasEAN13(CodBarras: string; Imagem: TCanvas);
    procedure DesenhaBarras(SequenciaHexa: string; Imagem: TCanvas);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses UnCriaCodBarrasImpressao;

{$R *.dfm}

//------------------------------------------------------------------------------
//
// .------------------------------------.
// | | Tabela A | Tabela B | Tabela C |
// |---+----------+----------+----------|
// | 0 | 0001101 | 0100111 | 1110010 |
// | 1 | 0011001 | 0110011 | 1100110 |
// | 2 | 0010011 | 0011011 | 1101100 |
// | 3 | 0111101 | 0011011 | 1000010 |
// | 4 | 0100011 | 0011101 | 1011100 |
// | 5 | 0110001 | 0111001 | 1001110 |
// | 6 | 0101111 | 0000101 | 1010000 |
// | 7 | 0111011 | 0010001 | 1000100 |
// | 8 | 0110111 | 0001001 | 1001000 |
// | 9 | 0001011 | 0010111 | 1110100 |
// .------------------------------------.
// Tabela Auxiliar
// .-----------------------.
// | Algarismo | Seqüência |
// |-----------+-----------|
// | 0 | AAAAAA |
// | 1 | AABABB |
// | 2 | AABBAB |
// | 3 | AABBBA |
// | 4 | ABAABB |
// | 5 | ABBAAB |
// | 6 | ABBBAA |
// | 7 | ABABAB |
// | 8 | ABABBA |
// | 9 | ABBABA |
// .-----------------------.
//
// Gerae código de barras padrão EAN13

procedure TForm1.GeraBarrasEAN13(CodBarras: string; Imagem: TCanvas);
const
  TabelaA: array[0..9] of string[7] = ('0001101', '0011001', '0010011', 
'0111101', '0100011', '0110001', '0101111', '0111011', '0110111', '0001011');
  TabelaB: array[0..9] of string[7] = ('0100111', '0110011', '0011011', 
'0011011', '0011101', '0111001', '0000101', '0010001', '0001001', '0010111');
  TabelaC: array[0..9] of string[7] = ('1110010', '1100110', '1101100', 
'1000010', '1011100', '1001110', '1010000', '1000100', '1001000', '1110100');
  TabAux: array[0..9] of string[6] = ('AAAAAA', 'AABABB', 'AABBAB', 'AABBBA', 
'ABAABB', 'ABBAAB', 'ABBBAA', 'ABABAB', 'ABABBA', 'ABBABA');
var
  Codigo: string;
  Formato: string;
  PegaDaTabela: string;
  DecimoTerceiroDig: Byte;
  Cont: Byte;
begin
  Formato := '';
  Codigo := CodBarras;
  DecimoTerceiroDig := StrToIntDef(CodBarras[1], 0);
  {----------------------------------------------------------------------------}
  { Tendo o 13º dígito definido, posso definir o padrão de impressão das barras}
  { no primeiro conjunto de 6 dígitos baseado na tabela Auxiliar. }
  {----------------------------------------------------------------------------}
  PegaDaTabela := TabAux[DecimoTerceiroDig] + 'CCCCCC';
  Formato := Formato + '101'; //--> Barra Auxiliar de Guarda 'Esquerda'
  for Cont := 1 to Length(PegaDaTabela) do
  begin

    case PegaDaTabela[Cont] of
      'A': Formato := Formato + TabelaA[StrToInt(Codigo[Cont + 1])];
      'B': Formato := Formato + TabelaB[StrToInt(Codigo[Cont + 1])];
      'C': Formato := Formato + TabelaC[StrToInt(Codigo[Cont + 1])];
    end;

    if Cont = 6 then
      Formato := Formato + '01010'; //--> Barra Auxiliar de Guarda 'Central'

  end;
  Formato := Formato + '101'; //--> Barra Auxiliar de Guarda 'Direita'

  //------ Desenha o código alfa-numérico na imagem
  Imagem.Font.Size := 10;
  Imagem.Brush.Color := ClWhite;
  Imagem.Pen.Color := ClBlack;
  Imagem.TextOut(02, 51, Copy(CodBarras, 01, 01));
  Imagem.TextOut(13, 51, Copy(CodBarras, 02, 06));
  Imagem.TextOut(60, 51, Copy(CodBarras, 08, 06));
  //------ Desenha as barras na imagem
  DesenhaBarras(Formato, Imagem);
end;

procedure TForm1.DesenhaBarras(SequenciaHexa: string; Imagem: TCanvas);
var
  X, Y, H: LongInt;
  A, B, C, D: TPoint;
  I: Boolean;
begin

  Imagem.Brush.Color := ClWhite;
  Imagem.Pen.Color := ClBlack;
  x := 10;
  i := True;
  for y := 1 to Length(SequenciaHexa) do
  begin
    if SequenciaHexa[y] = '0' then
      Imagem.Pen.Color := ClWhite
    else
      Imagem.Pen.Color := ClBlack;
    h := 1;
    a.x := x;
    a.y := 0;
    b.x := x;
    b.y := 50;
    c.x := x + h - 1;
    c.y := 50;
    d.x := x + h - 1;
    d.y := 0;
    case Y of
      1..3, 46..50, 93..95:
        begin
          b.y := 55;
          c.y := 55;
        end;
    end;
    Imagem.Polygon([A, B, C, D]);
    i := not (i);
    x := x + h;
  end;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GeraBarrasEAN13('7891089060350', Image1.Canvas);
end;


       
____________________________________________________________________________________
Novo Yahoo! Cadê? - Experimente uma nova busca.
http://yahoo.com.br/oqueeuganhocomisso 

[As partes desta mensagem que não continham texto foram removidas]