vpdfbarcode.pas

生成PDF文档的控件

    ('E', 'o', 'E', 'o', 'E', 'o'),
    ('E', 'o', 'E', 'o', 'o', 'E'),
    ('E', 'o', 'o', 'E', 'o', 'E')
    );

function TVPDFBarcode.Code_UPC_E0: AnsiString;
var
  I, j: integer;
  tmp: AnsiString;
  c: AnsiChar;
begin
  FText := SetLen(7);
  tmp := DoCheckSumming(copy(FText, 1, 6));
  c := tmp[7];
  if FCheckSum then
    FText := tmp
  else
    tmp := FText;
  Result := '505';
  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';
end;

function TVPDFBarcode.Code_UPC_E1: AnsiString;
var
  I, j: integer;
  tmp: AnsiString;
  c: AnsiChar;
begin
  FText := SetLen(7);
  tmp := DoCheckSumming(copy(FText, 1, 6));
  c := tmp[7];
  if FCheckSum then
    FText := tmp
  else
    tmp := FText;
  Result := '505';
  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';
end;

function getSupp(Nr: AnsiString): AnsiString;
var
  I, Fak, Sum: Integer;
  tmp: AnsiString;
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(String(tmp[I])) * 9)
    else
      Sum := Sum + (StrToInt(String(tmp[I])) * 3);
    dec(Fak);
  end;
  Sum := ((Sum mod 10) mod 10) mod 10;
  Result := tmp + AnsiString(IntToStr(Sum));
end;

function TVPDFBarcode.Code_Supp5: AnsiString;
var
  I, j: integer;
  tmp: AnsiString;
  c: AnsiChar;
begin
  FText := SetLen(5);
  tmp := getSupp(copy(FText, 1, 5) + '0');
  c := tmp[6];
  if FCheckSum then
    FText := tmp
  else
    tmp := FText;
  Result := '506';
  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';
  end;
end;

function TVPDFBarcode.Code_Supp2: AnsiString;
var
  I, j: integer;
  tmp, mS: AnsiString;
begin
  FText := SetLen(2);
  I := StrToInt(String(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';
  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';
  end;
end;

procedure TVPDFBarcode.MakeModules;
begin
  case Typ of
    0, 1, 3, 13, 14, 4, 12, 15, 16, 17, 18, 19:
      begin
        if Ratio < 2.0 then
          Ratio := 2.0;
        if Ratio > 3.0 then
          Ratio := 3.0;
      end;
    2:
      begin
        if Ratio < 2.25 then
          Ratio := 2.25;
        if Ratio > 3.0 then
          Ratio := 3.0;
      end;
    5, 6, 7, 8, 9, 10, 11: ;
  end;
  Modules[0] := FModul;
  Modules[1] := Round(FModul * FRatio);
  Modules[2] := Modules[1] * 3 div 2;
  Modules[3] := Modules[1] * 2;
end;

procedure TVPDFBarcode.DoLines(data: AnsiString; Canvas: TCanvas);
var
  I: integer;
  lt: TVPDFBarLineType;
  Xadd: integer;
  Width, height: integer;
  a, b, c, d, Orgin: TPoint;
  Alpha: double;
begin
  Xadd := 0;
  Orgin.x := FLeft;
  Orgin.y := FTop;
  Alpha := FAngle / 180.0 * pi;
  Orgin := TranslateQuad2D(Alpha, Orgin, Point(Self.Width, Self.Height));
  with Canvas do
  begin
    Pen.Width := 1;
    for I := 1 to Length(data) do
    begin
      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 - 1;
      c.y := Height;
      d.x := Xadd + Width - 1;
      d.y := 0;
      a := Translate2D(Rotate2D(a, Alpha), Orgin);
      b := Translate2D(Rotate2D(b, Alpha), Orgin);
      c := Translate2D(Rotate2D(c, Alpha), Orgin);
      d := Translate2D(Rotate2D(d, Alpha), Orgin);
      Polygon([a, b, c, d]);
      Xadd := Xadd + Width;
    end;
  end;
end;

procedure TVPDFBarcode.DrawBarcode(Canvas: TCanvas);
var
  data: AnsiString;
  SaveFont: TFont;
  SavePen: TPen;
  SaveBrush: TBrush;
begin
  Savefont := TFont.Create;
  SavePen := TPen.Create;
  SaveBrush := TBrush.Create;
  data := MakeData;
  try
    Savefont.Assign(Canvas.Font);
    SavePen.Assign(Canvas.Pen);
    SaveBrush.Assign(Canvas.Brush);
    DoLines(data, Canvas);
    if FShowText <> bcoNone then
      DrawText(Canvas);
    Canvas.Font.Assign(savefont);
    Canvas.Pen.Assign(SavePen);
    Canvas.Brush.Assign(SaveBrush);
  finally
    Savefont.Free;
    SavePen.Free;
    SaveBrush.Free;
  end;
end;

procedure TVPDFBarcode.DrawText(Canvas: TCanvas);
var
  PosX, PosY: Integer;
  SaveFont: TFont;
  SColor: TColor;
begin
  with Canvas do
  begin
    SaveFont := TFont.Create;
    try
      Font.Color := FColorBar;
      Font.Assign(ShowTextFont);
      try
        Pen.Color := Font.Color;
        Brush.Color := clWhite;
        PosX := FLeft;
        PosY := FTop;
        if ShowTextPosition in [stpTopLeft, stpBottomLeft] then
          PosX := FLeft
        else
          if ShowTextPosition in [stpTopRight, stpBottomRight] then
            PosX := FLeft + Width - TextWidth(String(Text))
          else
            if ShowTextPosition in [stpTopCenter, stpBottomCenter] then
              PosX := FLeft + Trunc((Width - TextWidth(String(Text))) / 2);
        if ShowTextPosition in [stpTopLeft, stpTopCenter, stpTopRight] then
          PosY := FTop
        else
          if ShowTextPosition in [stpBottomLeft, stpBottomCenter, stpBottomRight] then
            PosY := FTop + Height - TextHeight(String(Text));
        if FShowText in [bcoCode, bcoBoth] then
        begin
          Pen.Color := FColor;
          SColor := Brush.Color;
          Brush.Color := FColor;
          Rectangle(PosX, PosY, PosX + TextWidth(String(Text)) + 2, PosY + TextHeight(String(Text)) { + 3});
          Brush.Color := SColor;
          Rectangle(FLeft - 1, FTop, FLeft + Width, FTop - 2);
          Rectangle(FLeft - 1, FTop + Height, FLeft + Width, FTop + Height + 2);
          Pen.Color := FColorBar;
          Brush.Color := FColorBar;
          Font.Color := FColorBar;
          TextOut(PosX, PosY, String(FText));
        end;
        if FShowText in [bcoTyp, bcoBoth] then
        begin
          TextOut(FLeft, FTop + Round(Font.Height * 2.5), String(GetTypText));
        end;
      finally
        Font.Assign(SaveFont);
      end;
    finally
      SaveFont.Free;
    end;
  end;
end;

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

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

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

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

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

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

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

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

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

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

function TVPDFBarcode.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);
end;

function TVPDFBarcode.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);
end;

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

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

function TVPDFBarcode.CheckSumModulo10(const Data: AnsiString): AnsiString;
var
  I, Fak, Sum: Integer;
begin
  Sum := 0;
  Fak := Length(Data);
  for I := 1 to Length(Data) do
  begin
    if (Fak mod 2) = 0 then
      Sum := Sum + (StrToInt(String(Data[i])) * 1)
    else
      Sum := Sum + (StrToInt(String(Data[i])) * 3);
    Dec(Fak);
  end;
  if (Sum mod 10) = 0 then
    Result := Data + '0'
  else
    Result := Data + AnsiString(IntToStr(10 - (Sum mod 10)));
end;

end.