stbarc.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

      ';'      : bcDigits[bcDigitPos + 1] := 27;
      '<'      : bcDigits[bcDigitPos + 1] := 28;
      '='      : bcDigits[bcDigitPos + 1] := 29;
      '>'      : bcDigits[bcDigitPos + 1] := 30;
      '?'      : bcDigits[bcDigitPos + 1] := 31;
      '@'      : bcDigits[bcDigitPos + 1] := 32;
      'A'..'Z' : bcDigits[bcDigitPos + 1] := 33 + Ord(c)-Ord('A');
      '['      : bcDigits[bcDigitPos + 1] := 59;
      '\'      : bcDigits[bcDigitPos + 1] := 60;
      ']'      : bcDigits[bcDigitPos + 1] := 61;
      '^'      : bcDigits[bcDigitPos + 1] := 62;
      '_'      : bcDigits[bcDigitPos + 1] := 63;
      #0, #31  : bcDigits[bcDigitPos + 1] := 64 + Ord(c);  {control characters}
      '`'      : bcDigits[bcDigitPos + 1] := 64;
      'a'..'z' : bcDigits[bcDigitPos + 1] := 65 + Ord(c)-Ord('a');
      '{'      : bcDigits[bcDigitPos + 1] := 91;
      '|'      : bcDigits[bcDigitPos + 1] := 92;
      '}'      : bcDigits[bcDigitPos + 1] := 93;
      '~'      : bcDigits[bcDigitPos + 1] := 94;
      #130     : bcDigits[bcDigitPos + 1] := 98; {rest are manufactured characters}
      #131     : bcDigits[bcDigitPos + 1] := 97;
      #132     : bcDigits[bcDigitPos + 1] := 96;
      #133     : bcDigits[bcDigitPos + 1] := 98;
      #134     : bcDigits[bcDigitPos + 1] := 100;
      #135     : bcDigits[bcDigitPos + 1] := 99;
      #136     : bcDigits[bcDigitPos + 1] := 103;
      #137     : bcDigits[bcDigitPos + 1] := 104;
      #138     : bcDigits[bcDigitPos + 1] := 105;
      #139     : bcDigits[bcDigitPos + 1] := 106;
    else
      RaiseStError(EStBarCodeError, stscInvalidCharacter);
    end;
    Inc (Index);
    Inc (bcDigitPos);
  end;

  function CountCode128Digits (Index : Integer) : Integer;
  begin
    Result := 0;
    while (Index <= Length (Characters)) and
          (Characters[Index] >= '0') and (Characters[Index] <= '9') do begin
      Inc (Result);
      Inc (Index);
    end;
  end;

  function CheckCode128Digits (Index : Integer; CharsLen : Integer) : Boolean;
  var
    NumDigits : Integer;
  begin
    Result := False;
    NumDigits := CountCode128Digits (Index);
    if NumDigits mod 2 <> 0 then begin
      Characters := Copy (Characters, 1, Index - 1) +
                    '0' + Copy (Characters, Index, CharsLen - Index + 1);
      Result := True;
    end;
  end;

  function GetCode128Digits : Integer;
  var
    I             : Integer;
    RLen          : Integer;
    CurMode       : TStCode128CodeSubset;
    NeedCharCount : Boolean;
    Skip          : Boolean;

  begin
    I := 1;
    Result := Length (Characters);
    RLen := 0;
    CurMode := Self.Code128Subset;
    NeedCharCount := Self.Code128Subset = csCodeC;

    while I <= Result do begin
      if (NeedCharCount) and
         (Characters[I] >= '0') and (Characters[I] <= '9') then begin
        NeedCharCount := False;
        if CheckCode128Digits (I, Result) then
          Inc (Result);
      end;

      Skip := False;
      if (ExtendedSyntax) and (Characters[I] = '\')  and
         (I < Result) then begin
        if ((Characters[I + 1] = 'A') or (Characters[I + 1] = 'a')) and
           (CurMode <> csCodeA) then begin
          Inc (RLen);
          bcDigits[RLen] := 101;
          CurMode := csCodeA;
          Skip := True;
        end else if ((Characters[I + 1] = 'B') or (Characters[I + 1] = 'b')) and
                    (CurMode <> csCodeB) then begin
          Inc (RLen);
          bcDigits[RLen] := 100;
          CurMode :=csCodeB;
          Skip := True;
        end else if ((Characters[I + 1] = 'C') or (Characters[I + 1] = 'c')) and
                    (CurMode <> csCodeC) then begin
          NeedCharCount := True;
          Inc (RLen);
          bcDigits[RLen] := 99;
          CurMode := csCodeC;
          Skip := True;
        end else if (Characters[I + 1] = '\') then begin
          GetACode128ABDigit ('\', I, RLen);
          Skip := True;
        end;
        Inc (I);
      end;

      if not Skip then
        case CurMode of
          csCodeC :
            GetACode128CDigit (Characters[I], I, RLen);
          else
            GetACode128ABDigit (Characters[I], I, RLen);
        end
      else
        Inc (I);
    end;
    Result := RLen;
  end;

var
  I, J : Integer;
  S    : string[2];
begin
  FillChar(bcDigits, SizeOf(bcDigits), #0);
  Result := 0;

  case FBarCodeType of
    bcUPC_A, bcUPC_E, bcEAN_8, bcEAN_13, bcInterleaved2of5 :
      begin
        Result := Length(Characters);
        for I := 1 to Result do
          bcDigits[I] := StrToInt(Characters[I]);
      end;
    bcCodabar :
      begin
        Result := Length(Characters);
        for I := 1 to Result do begin
          case Characters[I] of
            '0'..'9' : bcDigits[I] := StrToInt(Characters[I]);
            '-'      : bcDigits[I] := 10;
            '$'      : bcDigits[I] := 11;
            ':'      : bcDigits[I] := 12;
            '/'      : bcDigits[I] := 13;
            '.'      : bcDigits[I] := 14;
            '+'      : bcDigits[I] := 15;
            'A', 'a' : bcDigits[I] := 16;
            'B', 'b' : bcDigits[I] := 17;
            'C', 'c' : bcDigits[I] := 18;
            'D', 'd' : bcDigits[I] := 19;
          else
            RaiseStError(EStBarCodeError, stscInvalidCharacter);
          end;
        end;
      end;
    bcCode11 :
      begin
        Result := Length(Characters);
        for I := 1 to Result do begin
          case Characters[I] of
            '0'..'9' : bcDigits[I] := StrToInt(Characters[I]);
            '-'      : bcDigits[I] := 10;
          else
            RaiseStError(EStBarCodeError, stscInvalidCharacter);
          end;
        end;
      end;
    bcCode39 :
      begin
        Result := Length(Characters);
        for I := 1 to Result do begin
          case Characters[I] of
            '0'..'9' : bcDigits[I] := StrToInt(Characters[I]);
            'A'..'Z' : bcDigits[I] := Ord(Characters[I]) - Ord('A') + 10;
            '-'      : bcDigits[I] := 36;
            '.'      : bcDigits[I] := 37;
            ' '      : bcDigits[I] := 38;
            '$'      : bcDigits[I] := 39;
            '/'      : bcDigits[I] := 40;
            '+'      : bcDigits[I] := 41;
            '%'      : bcDigits[I] := 42;
            '*'      : bcDigits[I] := 43;
          else
            RaiseStError(EStBarCodeError, stscInvalidCharacter);
          end;
        end;
      end;
    bcCode93 :
      begin
        Result := Length(Characters);
        J := 1;
        I := 1;
        while I <= Result do begin
          S := Code93Map[Characters[I]];
          if Length(S) > 1 then begin
            case S[1] of
              '$' : bcDigits[J] := 43; {(+)}
              '%' : bcDigits[J] := 44; {(%)}
              '/' : bcDigits[J] := 45; {(/)}
              '+' : bcDigits[J] := 46; {(+)}
            else
              RaiseStError(EStBarCodeError, stscInvalidCharacter);
            end;
            Inc(J);
            S := S[2];
          end;

          case S[1] of
            '0'..'9' : bcDigits[J] := Ord(S[1])-Ord('0');
            'A'..'Z' : bcDigits[J] := 10 + Ord(S[1])-Ord('A');
            '-'      : bcDigits[J] := 36;
            '.'      : bcDigits[J] := 37;
            ' '      : bcDigits[J] := 38;
            '$'      : bcDigits[J] := 39;
            '/'      : bcDigits[J] := 40;
            '+'      : bcDigits[J] := 41;
            '%'      : bcDigits[J] := 42;
          else
            RaiseStError(EStBarCodeError, stscInvalidCharacter);
          end;
          Inc(I);
          Inc(J);
        end;
        Result := J;
      end;
    bcCode128 :
      Result := GetCode128Digits;
  end;
end;

function TStBarCode.GetVersion : string;
begin
  Result := StVersionStr;
end;

procedure TStBarCode.Loaded;
begin
  inherited Loaded;

  CalcBarCode;
end;

procedure TStBarCode.Paint;
var
  Margin : Integer;
  R      : TRect;
begin
  {use our font}
  Canvas.Font := Font;

  {clear the canvas}
  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(ClientRect);

  {adjust height of rect to provide top and bottom margin}
  R := ClientRect;
  Margin := RectHeight(R)*10 div 100;
  InflateRect(R, 0, -Margin);
  PaintPrim(R);
end;

procedure TStBarCode.PaintPrim(const R : TRect);
begin
  Canvas.Brush.Style := bsClear;
  Canvas.Brush.Color := FBarColor;
  Canvas.Pen.Color := FBarColor;
  DrawBarCode(R);
end;

procedure TStBarCode.PaintToCanvas(ACanvas : TCanvas; ARect : TRect);
var
  Margin  : Integer;
  SavedDC : LongInt;
  R       : TRect;
begin
  Canvas.Handle := ACanvas.Handle;
  SavedDC := SaveDC(ACanvas.Handle);
  try
    {use our font}
    Canvas.Font := Font;

    {clear the specified area of the canvas}
    Canvas.Brush.Color := Color;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(ARect);

    {adjust height of rect to provide top and bottom margin}
    R := ARect;
    Margin := RectHeight(R)*10 div 100;
    InflateRect(R, 0, -Margin);
    PaintPrim(R);
  finally
    Canvas.Handle := 0;
    RestoreDC(ACanvas.Handle, SavedDC);
  end;
end;

procedure TStBarCode.PaintToCanvasSize(ACanvas : TCanvas; X, Y, H : Double);
var
  TH             : Integer;
  PixelsPerInchX : Integer;
  PixelsPerInchY : Integer;
  OldPPI         : Integer;
  SavedDC        : LongInt;
  R              : TRect;
  SmallestWidth  : Double;
begin
  Canvas.Handle := ACanvas.Handle;
  SavedDC := SaveDC(ACanvas.Handle);
  try
    {get some information about this device context}
    PixelsPerInchX := GetDeviceCaps(Canvas.Handle, LOGPIXELSX);
    PixelsPerInchY := GetDeviceCaps(Canvas.Handle, LOGPIXELSY);

    OldPPI := Canvas.Font.PixelsPerInch;
    {this is necessary because of a Delphi buglet}
    Canvas.Font.PixelsPerInch := PixelsPerInchY;

    {use our font}
    Canvas.Font := Font;

    {determine narrowest line width}
    SmallestWidth := SmallestLineWidth(PixelsPerInchX);

    {find sizes for the BarCode elements}
    bcBarModWidth := Round(FBarWidth/1000 * PixelsPerInchX);
    if bcBarModWidth < FBarToSpaceRatio then
      bcBarModWidth := Round(FBarToSpaceRatio);
    if bcBarModWidth < SmallestWidth then
      bcBarModWidth := Round(SmallestWidth);
    bcSpaceModWidth := Round(bcBarModWidth / FBarToSpaceRatio);
    CalcBarCodeWidth;

    {convert to a rect}
    R := Rect(Round(X * PixelsPerInchX),
              Round(Y * PixelsPerInchY),
              Round(X * PixelsPerInchX) + bcNormalWidth + bcSpaceWidth + bcSupplementWidth,
              Round((Y + H) * PixelsPerInchY));

    {increase height of rect to allow for text}
    if FShowCode and (Code > '') then begin
      TH :=Canvas.TextHeight(Code);
      Inc(R.Bottom, TH + (TH div 4));
    end;

    PaintPrim(R);
    Canvas.Font.PixelsPerInch := OldPPI;
    Invalidate;
  finally
    Canvas.Handle := 0;
    RestoreDC(ACanvas.Handle, SavedDC);
  end;
end;

procedure TStBarCode.PaintToDC(DC : hDC; ARect : TRect);
var
  Margin  : Integer;
  SavedDC : LongInt;
  R       : TRect;
begin
  Canvas.Handle := DC;
  SavedDC := SaveDC(DC);
  try
    {use our font}
    Canvas.Font := Font;

    {clear the specified area of the canvas}
    Canvas.Brush.Color := Color;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(ARect);

    {adjust height of rect to provide top and bottom margin}
    R := ARect;
    Margin := RectHeight(R)*10 div 100;
    InflateRect(R, 0, -Margin);
    PaintPrim(R);
  finally
    Canvas.Handle := 0;
    RestoreDC(DC, SavedDC);
  end;
end;

procedure TStBarCode.PaintToDCSize(DC : hDC; X, Y, W, H : Double);
begin
  Canvas.Handle := DC;
  PaintToCanvasSize(Canvas, X, Y, H);
end;

procedure TStBarCode.SaveToFile(const FileName : string);
var
  Bitmap : TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := ClientWidth;
    Bitmap.Height := ClientHeight;
    PaintToDC(Bitmap.Canvas.Handle, ClientRect);
    Bitmap.SaveToFile(FileName);
  finally
    Bitmap.Free;
  end
end;

procedure TStBarCode.SetAddCheckChar(Value : Boolean);
begin
  if Value <> FAddCheckChar then begin
    FAddCheckChar := Value;
    CalcBarCode;
    Invalidate;
  end;
end;

procedure TStBarCode.SetBarCodeType(Value : TStBarCodeType);
begin
  if Value <> FBarCodeType then begin
    FBarCodeType := Value;
    CalcBarCode;
    Invalidate;
  end;
end;

procedure TStBarCode.SetBarColor(Value : TColor);
begin
  if Value <> FBarColor then begin
    FBarColor := Value;
    Invalidate;
  end;
end;

procedure TStBarCode.SetBarToSpaceRatio(Value : Double);
begin
  {always uses a bar to space ratio of 1}
  if FBarCodeType in [bcInterleaved2of5, bcCode11, bcCode39, bcCode93, bcCode128] then
    Value := 1;

  if Value <> FBarToSpaceRatio then begin
    FBarToSpaceRatio := Value;
    CalcBarCode;
    Invalidate;
  end;
end;

procedure TStBarCode.SetBarNarrowToWide