rm_barcode.pas

中小企业管理系统------ ERP系统原代码

{find Codabar}
  function Find_Codabar(c: char): integer;
  var
    i: integer;
  begin
    for i := 0 to High(tabelle_cb) do
    begin
      if c = tabelle_cb[i].c then
      begin
        result := i;
        exit;
      end;
    end;
    result := -1;
  end;

var
  i, idx: integer;
begin
  result := tabelle_cb[Find_Codabar('A')].data + '0';
  for i := 1 to Length(FText) do
  begin
    idx := Find_Codabar(FText[i]);
    result := result + tabelle_cb[idx].data + '0';
  end;
  result := result + tabelle_cb[Find_Codabar('B')].data;
end;



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

{Assist function}

function TRMBarcode.SetLen(pI: byte): string;
begin
  if Length(FText) > pI then
    Result := Copy(FText, 1, pI) else
    Result := StringOfChar('0', pI - Length(FText)) + FText;
end;



function TRMBarcode.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 TRMBarcode.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 + '05050'; {Stopcode}
end;

function TRMBarcode.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 + '05050'; {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 TRMBarcode.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 TRMBarcode.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 TRMBarcode.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 TRMBarcode.DoLines(data: string; Canvas: TCanvas);

var i: integer;
  lt: TRMBarLineType;
  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 TRMBarcode.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}

   {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.
}


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

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

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

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

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

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

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

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

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

function TRMBarcode.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 TRMBarcode.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;




end.



//此源码由程序太平洋收集整理发布,任何人都可自由转载,但需保留本站信息
//╭⌒╮┅~ ¤　欢迎光临程序太平洋╭⌒╮
//╭⌒╭⌒╮╭⌒╮～╭⌒╮  ︶  ,︶︶
//,︶︶︶︶,''︶~~ ,''~︶︶　 ,''
//╔　╱◥███◣═╬╬╬╬╬╬╬╬╬╗
//╬ ︱田︱田 田 ︱　　　　　　　　　 ╬
//╬　　　　　　　http://www.5ivb.net ╬
//╬　 ╭○╮●　                   　╬
//╬　　/■\/■\　　                  ╬
//╬　　 <|　||　   有希望,就有成功！ ╬
//╬　　　　　　　　　　　　　　　　　╬
//╚╬╬╬╬╬╬╬╬╬╬╗  ╔╬╬╬╬╝
//
//说明：
//专业提供VB、．NET、Delphi、ASP、PB源码下载
//包括:程序源码,控件,商业源码,系统方案，开发工具，书籍教程，技术文档