rm_asbarcode.pas

这是一个功能强大

{---------------}

{Assist function}

function TAsBarcode.SetLen(pI: byte): string;
begin
  Result := StringOfChar('0', pI - Length(FText)) + FText;
{
   old implementation, if your Delphi version does not support
   StringOfChar()

  Result := FText;
  while Length(Result) < pI do
    Result:='0'+Result;
}
end;



function TAsBarcode.Code_UPC_A: string;
var
  i: integer;
  tmp: string;
begin
  FText := SetLen(12);
  if FCheckSum then tmp := DoCheckSumming(copy(FText, 1, 11));
  if FCheckSum then FText := tmp else tmp := FText;
  result := '505'; {Startcode}
  for i := 1 to 6 do
    result := result + tabelle_EAN_A[tmp[i]];
  result := result + '05050'; {Trennzeichen}
  for i := 7 to 12 do
    result := result + tabelle_EAN_C[tmp[i]];
  result := result + '505'; {Stopcode}
end;


{UPC E Parity Pattern Table , Number System 0}
const tabelle_UPC_E0: array['0'..'9', 1..6] of char =
  (
    ('E', 'E', 'E', 'o', 'o', 'o'), { 0 }
    ('E', 'E', 'o', 'E', 'o', 'o'), { 1 }
    ('E', 'E', 'o', 'o', 'E', 'o'), { 2 }
    ('E', 'E', 'o', 'o', 'o', 'E'), { 3 }
    ('E', 'o', 'E', 'E', 'o', 'o'), { 4 }
    ('E', 'o', 'o', 'E', 'E', 'o'), { 5 }
    ('E', 'o', 'o', 'o', 'E', 'E'), { 6 }
    ('E', 'o', 'E', 'o', 'E', 'o'), { 7 }
    ('E', 'o', 'E', 'o', 'o', 'E'), { 8 }
    ('E', 'o', 'o', 'E', 'o', 'E') { 9 }
    );

function TAsBarcode.Code_UPC_E0: string;
var i, j: integer;
  tmp: string;
  c: char;
begin
  FText := SetLen(7);
  tmp := DoCheckSumming(copy(FText, 1, 6));
  c := tmp[7];
  if FCheckSum then FText := tmp else tmp := FText;
  result := '505'; {Startcode}
  for i := 1 to 6 do
  begin
    if tabelle_UPC_E0[c, i] = 'E' then
    begin
      for j := 1 to 4 do result := result + tabelle_EAN_C[tmp[i], 5 - j];
    end
    else
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end;
  end;
  result := result + '050505'; {Stopcode}
end;

function TAsBarcode.Code_UPC_E1: string;
var i, j: integer;
  tmp: string;
  c: char;
begin
  FText := SetLen(7);
  tmp := DoCheckSumming(copy(FText, 1, 6));
  c := tmp[7];
  if FCheckSum then FText := tmp else tmp := FText;
  result := '505'; {Startcode}
  for i := 1 to 6 do
  begin
    if tabelle_UPC_E0[c, i] = 'E' then
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end
    else
    begin
      for j := 1 to 4 do result := result + tabelle_EAN_C[tmp[i], 5 - j];
    end;
  end;
  result := result + '050505'; {Stopcode}
end;

{assist function}

function getSupp(Nr: string): string;
var i, fak, sum: Integer;
  tmp: string;
begin
  sum := 0;
  tmp := copy(nr, 1, Length(Nr) - 1);
  fak := Length(tmp);
  for i := 1 to length(tmp) do
  begin
    if (fak mod 2) = 0 then
      sum := sum + (StrToInt(tmp[i]) * 9)
    else
      sum := sum + (StrToInt(tmp[i]) * 3);
    dec(fak);
  end;
  sum := ((sum mod 10) mod 10) mod 10;
  result := tmp + IntToStr(sum);
end;

function TAsBarcode.Code_Supp5: string;
var i, j: integer;
  tmp: string;
  c: char;
begin
  FText := SetLen(5);
  tmp := getSupp(copy(FText, 1, 5) + '0');
  c := tmp[6];
  if FCheckSum then FText := tmp else tmp := FText;
  result := '506'; {Startcode}
  for i := 1 to 5 do
  begin
    if tabelle_UPC_E0[c, (6 - 5) + i] = 'E' then
    begin
      for j := 1 to 4 do result := result + tabelle_EAN_C[tmp[i], 5 - j];
    end
    else
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end;
    if i < 5 then result := result + '05'; { character delineator }
  end;
end;

function TAsBarcode.Code_Supp2: string;
var i, j: integer;
  tmp, mS: string;
begin
  FText := SetLen(2);
  i := StrToInt(Ftext);
  case i mod 4 of
    3: mS := 'EE';
    2: mS := 'Eo';
    1: mS := 'oE';
    0: mS := 'oo';
  end;
  tmp := getSupp(copy(FText, 1, 5) + '0');

  if FCheckSum then FText := tmp else tmp := FText;
  result := '506'; {Startcode}
  for i := 1 to 2 do
  begin
    if mS[i] = 'E' then
    begin
      for j := 1 to 4 do result := result + tabelle_EAN_C[tmp[i], 5 - j];
    end
    else
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end;
    if i < 2 then result := result + '05'; { character delineator }
  end;
end;

{---------------}




procedure TAsBarcode.MakeModules;
begin
  case Typ of
    bcCode_2_5_interleaved,
      bcCode_2_5_industrial,
      bcCode39,
      bcCodeEAN8,
      bcCodeEAN13,
      bcCode39Extended,
      bcCodeCodabar,
      bcCodeUPC_A,
      bcCodeUPC_E0,
      bcCodeUPC_E1,
      bcCodeUPC_Supp2,
      bcCodeUPC_Supp5:

      begin
        if Ratio < 2.0 then Ratio := 2.0;
        if Ratio > 3.0 then Ratio := 3.0;
      end;

    bcCode_2_5_matrix:
      begin
        if Ratio < 2.25 then Ratio := 2.25;
        if Ratio > 3.0 then Ratio := 3.0;
      end;
    bcCode128A,
      bcCode128B,
      bcCode128C,
      bcCode93,
      bcCode93Extended,
      bcCodeMSI,
      bcCodePostNet: ;
  end;


  modules[0] := FModul;
  modules[1] := Round(FModul * FRatio);
  modules[2] := modules[1] * 3 div 2;
  modules[3] := modules[1] * 2;
end;





{
Draw the Barcode

Parameter :
'data' holds the pattern for a Barcode.
A barcode begins always with a black line and
ends with a black line.

The white Lines builds the space between the black Lines.

A black line must always followed by a white Line and vica versa.

Examples:
  '50505'   // 3 thin black Lines with 2 thin white Lines
  '606'     // 2 fat black Lines with 1 thin white Line

  '5605015' // Error


data[] : see procedure OneBarProps

}

procedure TAsBarcode.DoLines(data: string; Canvas: TCanvas);

var i: integer;
  lt: TBarLineType;
  xadd: integer;
  width, height: integer;
  a, b, c, d, {Edges of a line (we need 4 Point because the line}
          {is a recangle}
  orgin: TPoint;
  alpha: double;
begin
  xadd := 0;
  orgin.x := FLeft;
  orgin.y := FTop;

  alpha := FAngle / 180.0 * pi;

  { Move the orgin so the entire barcode ends up in the visible region. }
  orgin := TranslateQuad2D(alpha, orgin, Point(Self.Width, Self.Height));

  with Canvas do begin
    Pen.Width := 1;

    for i := 1 to Length(data) do {examine the pattern string}
    begin

      {
      input:  pattern code
      output: Width and Linetype
      }
      OneBarProps(data[i], width, lt);

      if (lt = black) or (lt = black_half) then
      begin
        Pen.Color := FColorBar;
      end
      else
      begin
        Pen.Color := FColor;
      end;
      Brush.Color := Pen.Color;

      if lt = black_half then
        height := FHeight * 2 div 5
      else
        height := FHeight;





      a.x := xadd;
      a.y := 0;

      b.x := xadd;
      b.y := height;

    {c.x := xadd+width;}
      c.x := xadd + Width - 1; {23.04.1999 Line was 1 Pixel too wide}
      c.y := Height;

    {d.x := xadd+width;}
      d.x := xadd + Width - 1; {23.04.1999 Line was 1 Pixel too wide}
      d.y := 0;

    {a,b,c,d builds the rectangle we want to draw}


    {rotate the rectangle}
      a := Translate2D(Rotate2D(a, alpha), orgin);
      b := Translate2D(Rotate2D(b, alpha), orgin);
      c := Translate2D(Rotate2D(c, alpha), orgin);
      d := Translate2D(Rotate2D(d, alpha), orgin);

    {draw the rectangle}
      Polygon([a, b, c, d]);

      xadd := xadd + width;
    end;
  end;
end;



procedure TAsBarcode.DrawBarcode(Canvas: TCanvas);
var
  data: string;
  SaveFont: TFont;
  SavePen: TPen;
  SaveBrush: TBrush;
begin
  Savefont := TFont.Create;
  SavePen := TPen.Create;
  SaveBrush := TBrush.Create;


  {get barcode pattern}
  data := MakeData;


  try
   {store Canvas properties}
    Savefont.Assign(Canvas.Font);
    SavePen.Assign(Canvas.Pen);
    SaveBrush.Assign(Canvas.Brush);

    DoLines(data, Canvas); {draw the barcode}

    if FShowText <> bcoNone then
      DrawText(Canvas); {show readable Text}


   {restore old Canvas properties}
    Canvas.Font.Assign(savefont);
    Canvas.Pen.Assign(SavePen);
    Canvas.Brush.Assign(SaveBrush);
  finally
    Savefont.Free;
    SavePen.Free;
    SaveBrush.Free;
  end;
end;


{
  draw contents and type/name of barcode
  as human readable text at the left
  upper edge of the barcode.

  main use for this procedure is testing.

  note: this procedure changes Pen and Brush
  of the current canvas.

  Modifications from Roberto Parola to improve the text output
  Its useful to print the Text (code) on the barcode, in case the pen
  doesnt read the barcode.
  I didnt implement the EAN8 and EAN13 way to print the code, because
  the first character is outside of the bound of the barcode, and this
  can cause some problems (expecially in a report)
}

procedure TAsBarcode.DrawText(Canvas: TCanvas);
var
  PosX, PosY: Integer;
  SaveFont: TFont;
begin
  with Canvas do
  begin
//    Font.Size := 5;
    {the fixed font size is a problem, if you
     use very large or small barcodes}
// then i thought well to modify it

// I know... you already did it in the DrawBarcode function, and this one is
// called only by there... but i want to be sure :)
    SaveFont := TFont.Create;
    try
      Font.Assign(ShowTextFont);
      try
        Pen.Color := Font.Color;
        Brush.Color := clWhite;


// I only consider the Text (code) position.
// As stated by Andreas Schmidt
        PosX := FLeft;
        PosY := FTop;

        if ShowTextPosition in [stpTopLeft, stpBottomLeft] then
          PosX := FLeft
        else
          if ShowTextPosition in [stpTopRight, stpBottomRight] then
            PosX := FLeft + Width - TextWidth(Text)
          else
            // i know, the last IF is useless, but i like it this way
            if ShowTextPosition in [stpTopCenter, stpBottomCenter] then
              PosX := FLeft + Trunc((Width - TextWidth(Text)) / 2);

        if ShowTextPosition in [stpTopLeft, stpTopCenter, stpTopRight] then
          PosY := FTop
        else
          if ShowTextPosition in [stpBottomLeft, stpBottomCenter, stpBottomRight] then
            PosY := FTop + Height - TextHeight(Text);

        if FShowText in [bcoCode, bcoBoth] then
//          TextOut(FLeft, FTop, FText);         {contents of Barcode}
          TextOut(PosX, PosY, FText); {contents of Barcode}
        if FShowText in [bcoTyp, bcoBoth] then
          TextOut(FLeft, FTop + Round(Font.Height * 2.5), GetTypText); {type/name of barcode}
      finally
        Font.Assign(SaveFont);
      end;
    finally
      SaveFont.Free;
    end;
  end;
end;


procedure TAsBarcode.DoChange;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TAsBarcode.SetRatio(const Value: Double);
begin
  if Value <> FRatio then
  begin
    FRatio := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetTyp(const Value: TBarcodeType);
begin
  if Value <> FTyp then
  begin
    FTyp := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetAngle(const Value: Double);
begin
  if Value <> FAngle then
  begin
    FAngle := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetText(const Value: string);
begin
  if Value <> FText then
  begin
    FText := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetShowText(const Value: TBarcodeOption);
begin
  if Value <> FShowText then
  begin
    FShowText := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetTop(const Value: Integer);
begin
  if Value <> FTop then
  begin
    FTop := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetLeft(const Value: Integer);
begin
  if Value <> FLeft then
  begin
    FLeft := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetCheckSum(const Value: Boolean);
begin
  if Value <> FCheckSum then
  begin
    FCheckSum := Value;
    DoChange;
  end;
end;

procedure TAsBarcode.SetHeight(const Value: integer);
begin
  if Value <> FHeight then
  begin
    FHeight := Value;
    DoChange;
  end;
end;

function TAsBarcode.GetCanvasHeight: Integer;
var
  alpha: Extended;
begin
  alpha := FAngle / 180.0 * pi;
  Result := Round(abs(sin(alpha)) * Self.Width + abs(cos(alpha)) * Self.Height + 0.5); {.5 rounds up always}
end;

function TAsBarcode.GetCanvasWidth: Integer;
var
  alpha: Extended;
begin
  alpha := FAngle / 180.0 * pi;
  Result := Round(abs(cos(alpha)) * Self.Width + abs(sin(alpha)) * Self.Height + 0.5); { .5 rounds up always}
end;


procedure TAsBarcode.SetShowTextFont(const Value: TFont);
begin
  FShowTextFont.Assign(Value);
  DoChange;
end;

procedure TAsBarcode.SetShowTextPosition(const Value: TShowTextPosition);
begin
  if Value <> FShowTextPosition then
  begin
    FShowTextPosition := Value;
    DoChange;
  end;
end;

end.