pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
a19d68c54d5cf2a73990ff8f481b86d76f39ae5e
lazarus-ccr/components/systools/source/general/run/stbarc.pas

2472 lines
68 KiB
ObjectPascal
Raw Normal View History

systools: Initial commit of Lazarus port of TurboPower SysTools (incomplete). git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6140 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2018-01-16 23:57:15 +00:00
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* SysTools: StBarC.pas 4.04 *}
{*********************************************************}
{* SysTools: bar code components *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit StBarC;
interface
uses
{$IFDEF FPC}
LCLType, LCLIntf, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
Classes, ClipBrd, Controls, Graphics, SysUtils,
StBase, StConst;
const
{.Z+}
bcMaxBarCodeLen = 255;
bcGuardBarAbove = True;
bcGuardBarBelow = True;
bcDefNarrowToWideRatio = 2;
{.Z-}
type
TStBarKind = (bkSpace, bkBar, bkThreeQuarterBar, bkHalfBar, bkGuard, bkSupplement, bkBlankSpace);
{.Z+}
TStBarKindSet = set of TStBarKind;
TStDigitArray = array[1..bcMaxBarCodeLen] of Byte;
{.Z-}
{.Z+}
TStBarData = class
FKind : TStBarKindSet;
FModules : Integer;
public
property Kind : TStBarKindSet
read FKind
write FKind;
property Modules : Integer
read FModules
write FModules;
end;
{.Z-}
{.Z+}
TStBarCodeInfo = class
private
FBars : TList;
function GetBars(Index : Integer) : TStBarData;
function GetCount : Integer;
public
constructor Create;
virtual;
destructor Destroy;
override;
procedure Add(ModuleCount : Integer; BarKind : TStBarKindSet);
procedure Clear;
property Bars[Index : Integer] : TStBarData
read GetBars;
default;
property Count : Integer
read GetCount;
end;
{.Z-}
TStBarCodeType = (bcUPC_A, bcUPC_E, bcEAN_8, bcEAN_13,
bcInterleaved2of5, bcCodabar, bcCode11,
bcCode39, bcCode93, bcCode128);
TStCode128CodeSubset = (csCodeA, csCodeB, csCodeC);
TStBarCode = class(TGraphicControl)
protected {private}
{property variables}
{.Z+}
FAddCheckChar : Boolean;
FBarCodeType : TStBarCodeType;
FBarColor : TColor;
FBarToSpaceRatio : Double;
FBarNarrowToWideRatio : Integer;
FBarWidth : Double; {in mils}
FCode : String;
FCode128Subset : TStCode128CodeSubset;
FBearerBars : Boolean;
FShowCode : Boolean;
FShowGuardChars : Boolean;
FSupplementalCode : string;
FTallGuardBars : Boolean;
FExtendedSyntax : Boolean;
{internal variables}
bcBarInfo : TStBarCodeInfo;
bcBarModWidth : Integer; {width of single bar}
bcCheckK : Integer; {"K" check character for use by Code11}
bcDigits : TStDigitArray;
bcDigitCount : Integer;
bcSpaceModWidth : Integer; {width of empty space between bars}
bcNormalWidth : Integer;
bcSpaceWidth : Integer;
bcSupplementWidth: Integer;
{property methods}
function GetVersion : string;
procedure SetAddCheckChar(Value : Boolean);
procedure SetBarCodeType(Value : TStBarCodeType);
procedure SetBarColor(Value : TColor);
procedure SetBarToSpaceRatio(Value : Double);
procedure SetBarNarrowToWideRatio(Value: Integer);
procedure SetBarWidth(Value : Double);
procedure SetBearerBars(Value : Boolean);
procedure SetCode(const AValue : string);
procedure SetCode128Subset(Value : TStCode128CodeSubset);
procedure SetExtendedSyntax (const v : Boolean);
procedure SetShowCode(Value : Boolean);
procedure SetShowGuardChars(Value : Boolean);
procedure SetSupplementalCode(const Value : string);
procedure SetTallGuardBars(Value : Boolean);
procedure SetVersion(const Value : string);
{internal methods}
procedure CalcBarCode;
procedure CalcBarCodeWidth;
function DrawBar(XPos, YPos, AWidth, AHeight : Integer) : Integer;
procedure DrawBarCode(const R : TRect);
function GetDigits(Characters : string) : Integer;
procedure PaintPrim(const R : TRect);
function SmallestLineWidth(PixelsPerInch : Integer) : Double;
protected
procedure Loaded; override;
procedure Paint; override;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
{.Z-}
procedure CopyToClipboard;
procedure GetCheckCharacters(const S : string; var C, K : Integer);
function GetBarCodeWidth(ACanvas : TCanvas) : Double;
procedure PaintToCanvas(ACanvas : TCanvas; ARect : TRect);
procedure PaintToCanvasSize(ACanvas : TCanvas; X, Y, H : Double);
procedure PaintToDC(DC : hDC; ARect : TRect);
procedure PaintToDCSize(DC : hDC; X, Y, W, H : Double);
procedure SaveToFile(const FileName : string);
function Validate(DisplayError : Boolean) : Boolean;
published
{properties}
property Align;
property Anchors;
{$IFDEF FPC}
property BorderSpacing;
{$ENDIF}
property Color;
property Cursor;
property Enabled;
property Font;
property Height default 75;
property ParentColor;
property ParentFont;
property ParentShowHint;
property ShowHint;
property Visible;
property Width default 200;
property AddCheckChar : Boolean
read FAddCheckChar
write SetAddCheckChar;
property BarCodeType : TStBarCodeType
read FBarCodeType
write SetBarCodeType;
property BarColor : TColor
read FBarColor
write SetBarColor;
property BarToSpaceRatio : Double
read FBarToSpaceRatio
write SetBarToSpaceRatio;
property BarNarrowToWideRatio : Integer
read FBarNarrowToWideRatio
write SetBarNarrowToWideRatio
default bcDefNarrowToWideRatio;
property BarWidth : Double
read FBarWidth
write SetBarWidth;
property BearerBars : Boolean
read FBearerBars
write SetBearerBars;
property Code : string
read FCode
write SetCode;
property Code128Subset : TStCode128CodeSubset
read FCode128Subset
write SetCode128Subset;
property ExtendedSyntax : Boolean
read FExtendedSyntax write SetExtendedSyntax
default False;
property ShowCode : Boolean
read FShowCode
write SetShowCode;
property ShowGuardChars : Boolean
read FShowGuardChars
write SetShowGuardChars;
property SupplementalCode : string
read FSupplementalCode
write SetSupplementalCode;
property TallGuardBars : Boolean
read FTallGuardBars
write SetTallGuardBars;
property Version : string
read GetVersion
write SetVersion
stored False;
{events}
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
implementation
const
{left and right codes for UPC_A}
UPC_A_LeftHand : array[0..9] of string =
('0001101', {0}
'0011001', {1}
'0010011', {2}
'0111101', {3}
'0100011', {4}
'0110001', {5}
'0101111', {6}
'0111011', {7}
'0110111', {8}
'0001011' {9} );
UPC_A_RightHand : array[0..9] of string =
('1110010', {0}
'1100110', {1}
'1101100', {2}
'1000010', {3}
'1011100', {4}
'1001110', {5}
'1010000', {6}
'1000100', {7}
'1001000', {8}
'1110100' {9} );
const
UPC_E_OddParity : array[0..9] of string =
('0001101', {0}
'0011001', {1}
'0010011', {2}
'0111101', {3}
'0100011', {4}
'0110001', {5}
'0101111', {6}
'0111011', {7}
'0110111', {8}
'0001011' {9} );
UPC_E_EvenParity : array[0..9] of string =
('0100111', {0}
'0110011', {1}
'0011011', {2}
'0100001', {3}
'0011101', {4}
'0111001', {5}
'0000101', {6}
'0010001', {7}
'0001001', {8}
'0010111' {9} );
const
EAN_LeftHandA : array[0..9] of string =
('0001101', {0}
'0011001', {1}
'0010011', {2}
'0111101', {3}
'0100011', {4}
'0110001', {5}
'0101111', {6}
'0111011', {7}
'0110111', {8}
'0001011' {9} );
EAN_LeftHandB : array[0..9] of string =
('0100111', {0}
'0110011', {1}
'0011011', {2}
'0100001', {3}
'0011101', {4}
'0111001', {5}
'0000101', {6}
'0010001', {7}
'0001001', {8}
'0010111' {9} );
const
Interleaved_2of5 : array[0..9] of string =
('00110', {0}
'10001', {1}
'01001', {2}
'11000', {3}
'00101', {4}
'10100', {5}
'01100', {6}
'00011', {7}
'10010', {8}
'01010' {9} );
const
Codabar : array[0..19] of string =
{BSBSBSB} {bar-space-bar-space-bar...}
('0000011', {0}
'0000110', {1}
'0001001', {2}
'1100000', {3}
'0010010', {4}
'1000010', {5}
'0100001', {6}
'0100100', {7}
'0110000', {8}
'1001000', {9}
'0001100', {-}
'0011000', { $}
'1000101', {:}
'1010001', {/}
'1010100', {.}
'0010101', {+}
'0011010', {A}
'0101001', {B}
'0001011', {C}
'0001110' {D});
const
Code11 : array[0..11] of string =
{BSBSB} {bar-space-bar-space-bar...} {0-narrow, 1-wide}
('00001', {0}
'10001', {1}
'01001', {2}
'11000', {3}
'00101', {4}
'10100', {5}
'01100', {6}
'00011', {7}
'10010', {8}
'10000', {9}
'00100', {-}
'00110'); {stop character}
const
Code39 : array[0..43] of string =
{BSBSBSBSB} {bar-space-bar-space-bar...} {0-narrow, 1-wide}
('000110100', {0}
'100100001', {1}
'001100001', {2}
'101100000', {3}
'000110001', {4}
'100110000', {5}
'001110000', {6}
'000100101', {7}
'100100100', {8}
'001100100', {9}
'100001001', {A}
'001001001', {B}
'101001000', {C}
'000011001', {D}
'100011000', {E}
'001011000', {F}
'000001101', {G}
'100001100', {H}
'001001100', {I}
'000011100', {J}
'100000011', {K}
'001000011', {L}
'101000010', {M}
'000010011', {N}
'100010010', {O}
'001010010', {P}
'000000111', {Q}
'100000110', {R}
'001000110', {S}
'000010110', {T}
'110000001', {U}
'011000001', {V}
'111000000', {W}
'010010001', {X}
'110010000', {Y}
'011010000', {Z}
'010000101', {-}
'110000100', {.}
'011000100', {SPACE}
'010101000', { $}
'010100010', {/}
'010001010', {+}
'000101010', {%}
'010010100'); {*}
const
Code93 : array[0..46] of string =
{BSBSBS} {bar-space-bar-space-bar...} {0-narrow, 1-wide}
('131112', {0}
'111213', {1}
'111312', {2}
'111411', {3}
'121113', {4}
'121212', {5}
'121311', {6}
'111114', {7}
'131211', {8}
'141111', {9}
'211113', {A}
'211212', {B}
'211311', {C}
'221112', {D}
'221211', {E}
'231111', {F}
'112113', {G}
'112212', {H}
'112311', {I}
'122112', {J}
'132111', {K}
'111123', {L}
'111222', {M}
'111321', {N}
'121122', {O}
'131121', {P}
'212112', {Q}
'212211', {R}
'211122', {S}
'211221', {T}
'221121', {U}
'222111', {V}
'112122', {W}
'112221', {X}
'122121', {Y}
'123111', {Z}
'121131', {-}
'311112', {.}
'311211', {SPACE}
'321111', { $}
'112131', {/}
'113121', {+}
'211131', {%}
'121221', {($)}
'312111', {(%)}
'311121', {(/)}
'122211'); {(+)}
Code93Map : array[#0..#127] of string =
{Circle Code} {ASCII Code 93 }
('%U', {NL (%)U }
'$A', {SH ($)A }
'$B', {SX ($)B }
'$C', {EX ($)C }
'$D', {ET ($)D }
'$E', {EQ ($)E }
'$F', {AK ($)F }
'$G', {BL ($)G }
'$H', {BS ($)H }
'$I', {HT ($)I }
'$J', {LF ($)J }
'$K', {VT ($)K }
'$L', {FF ($)L }
'$M', {CR ($)M }
'$N', {SO ($)N }
'$O', {SI ($)O }
'$P', {DL ($)P }
'$Q', {D1 ($)Q }
'$R', {D2 ($)R }
'$S', {D3 ($)S }
'$T', {D4 ($)T }
'$U', {NK ($)U }
'$V', {SY ($)V }
'$W', {EB ($)W }
'$X', {CN ($)X }
'$Y', {EM ($)Y }
'$Z', {SB ($)Z }
'%A', {EC (%)A }
'%B', {FS (%)B }
'%C', {GS (%)C }
'%D', {RS (%)D }
'%E', {US (%)E }
' ', {Space Space }
'/A', {! (/)A }
'/B', {" (/)B }
'/C', {# (/)C }
'$', { $ (/)D or $}
'%', {% (/)E or %}
'/F', {& (/)F }
'/G', {' (/)G }
'/H', {( (/)H }
'/I', {) (/)I }
'/J', {* (/)J }
' +', {+ (/)K or +}
'/L', {, (/)L }
'-', {- (/)M or -}
'.', {. (/)N or .}
'/', {/ (/)O or /}
'0', {0 (/)P or 0}
'1', {1 (/)Q or 1}
'2', {2 (/)R or 2}
'3', {3 (/)S or 3}
'4', {4 (/)T or 4}
'5', {5 (/)U or 5}
'6', {6 (/)V or 6}
'7', {7 (/)W or 7}
'8', {8 (/)X or 8}
'9', {9 (/)Y or 9}
'/Z', {: (/)Z }
'%F', {; (%)F }
'%G', {< (%)G }
'%H', {= (%)H }
'%I', {> (%)I }
'%J', {? (%)J }
'%V', { (%)V }
'A', {A A }
'B', {B B }
'C', {C C }
'D', {D D }
'E', {E E }
'F', {F F }
'G', {G G }
'H', {H H }
'I', {I I }
'J', {J J }
'K', {K K }
'L', {L L }
'M', {M M }
'N', {N N }
'O', {O O }
'P', {P P }
'Q', {Q Q }
'R', {R R }
'S', {S S }
'T', {T T }
'U', {U U }
'V', {V V }
'W', {W W }
'X', {X X }
'Y', {Y Y }
'Z', {Z Z }
'%K', {[ (%)K }
'%L', {\ (%)L }
'%M', {] (%)M }
'%N', {^ (%)N }
'%O', {_ (%)O }
'%W', {` (%)W }
'+A', {a (+)A }
'+B', {b (+)B }
'+C', {c (+)C }
'+D', {d (+)D }
'+E', {e (+)E }
'+F', {f (+)F }
'+G', {g (+)G }
'+H', {h (+)H }
'+I', {i (+)I }
'+J', {j (+)J }
'+K', {k (+)K }
'+L', {l (+)L }
'+M', {m (+)M }
'+N', {n (+)N }
'+O', {o (+)O }
'+P', {p (+)P }
'+Q', {q (+)Q }
'+R', {r (+)R }
'+S', {s (+)S }
'+T', {t (+)T }
'+U', {u (+)U }
'+V', {v (+)V }
'+W', {w (+)W }
'+X', {x (+)X }
'+Y', {y (+)Y }
'+Z', {z (+)Z }
'%P', {{ (%)P }
'%Q', {| (%)Q }
'%R', {}{ (%)R }
'%S', {~ (%)S }
'%T'); { DEL (%)T }
const
Code128 : array[0..106] of string =
{BSBSBS} {Value CodeA CodeB CodeC}
('212222', {0 SPACE SPACE 00}
'222122', {1 ! ! 01}
'222221', {2 " " 02}
'121223', {3 # # 03}
'121322', {4 $ $ 04}
'131222', {5 % % 05}
'122213', {6 & & 06}
'122312', {7 ' ' 07}
'132212', {8 ( ( 08}
'221213', {9 ) ) 09}
'221312', {10 * * 10}
'231212', {11 + + 11}
'112232', {12 , , 12}
'122132', {13 - - 13}
'122231', {14 . . 14}
'113222', {15 / / 15}
'123122', {16 0 0 16}
'123221', {17 1 1 17}
'223211', {18 2 2 18}
'221132', {19 3 3 19}
'221231', {20 4 4 20}
'213212', {21 5 5 21}
'223112', {22 6 6 22}
'312131', {23 7 7 23}
'311222', {24 8 8 24}
'321122', {25 9 9 25}
'321221', {26 : : 26}
'312212', {27 ; ; 27}
'322112', {28 < < 28}
'322211', {29 = = 29}
'212123', {30 > > 30}
'212321', {31 ? ? 31}
'232121', {32 @ @ 32}
'111323', {33 A A 33}
'131123', {34 B B 34}
'131321', {35 C C 35}
'112313', {36 D D 36}
'132113', {37 E E 37}
'132311', {38 F F 38}
'211313', {39 G G 39}
'231113', {40 H H 40}
'231311', {41 I I 41}
'112133', {42 J J 42}
'112331', {43 K K 43}
'132131', {44 L L 44}
'113123', {45 M M 45}
'113321', {46 N N 46}
'133121', {47 O O 47}
'313121', {48 P P 48}
'211331', {49 Q Q 49}
'231131', {50 R R 50}
'213113', {51 S S 51}
'213311', {52 T T 52}
'213131', {53 U U 53}
'311123', {54 V V 54}
'311321', {55 W W 55}
'331121', {56 X X 56}
'312113', {57 Y Y 57}
'312311', {58 Z Z 58}
'332111', {59 [ [ 59}
'314111', {60 \ \ 60}
'221411', {61 ] ] 61}
'431111', {62 ^ ^ 62}
'111224', {63 _ _ 63}
'111422', {64 NU ` 64}
'121124', {65 SH a 65}
'121421', {66 SX b 66}
'141122', {67 EX c 67}
'141221', {68 ET d 68}
'112214', {69 EQ e 69}
'112412', {70 AK f 70}
'122114', {71 BL g 71}
'122411', {72 BS h 72}
'142112', {73 HT i 73}
'142211', {74 LF j 74}
'241211', {75 VT k 75}
'221114', {76 FF l 76}
'413111', {77 CR m 77}
'241112', {78 SO n 78}
'134111', {79 SI o 79}
'111242', {80 DL p 80}
'121142', {81 D1 q 81}
'121241', {82 D2 r 82}
'114212', {83 D3 s 83}
'124112', {84 D4 t 84}
'124211', {85 NK u 85}
'411212', {86 SY v 86}
'421112', {87 EB w 87}
'421211', {88 CN x 88}
'212141', {89 EM y 89}
'214121', {90 SB z 90}
'412121', (*91 EC { 91*)
'111143', {92 FS 92}
'111341', (*93 GS } 93*)
'131141', {94 RS ~ 94}
'114113', {95 US DEL 95}
'114311', {96 FNC 3 FNC 3 96} {use #132}
'411113', {97 FNC 2 FNC 2 97} {use #131}
'411311', {98 SHIFT SHIFT 98} {use #130}
'113141', {99 CODE C CODE C 99} {use #135}
'114131', {100 CODE B FNC 4 CODE B} {use #134}
'311141', {101 FNC 4 CODE A CODE A} {use #133}
'411131', {102 FNC 1 FNC 1 FNC 1 } {use #130}
'211412', {103 CODE A} {use #136}
'211214', {104 CODE B} {use #137}
'211232', {105 CODE C} {use #138}
'2331112');{106 STOP} {use #139}
{*** helper routines ***}
function RectWidth(const R : TRect) : Integer;
begin
Result := R.Right-R.Left;
end;
function RectHeight(const R : TRect) : Integer;
begin
Result := R.Bottom-R.Top;
end;
{*** TStBarCodeInfo ***}
procedure TStBarCodeInfo.Add(ModuleCount : Integer; BarKind : TStBarKindSet);
var
Bar : TStBarData;
begin
Bar := TStBarData.Create;
Bar.Modules := ModuleCount;
Bar.Kind := BarKind;
FBars.Add(Bar);
end;
procedure TStBarCodeInfo.Clear;
var
I : Integer;
begin
for I := 0 to FBars.Count-1 do
TStBarData(FBars[I]).Free;
FBars.Clear;
end;
constructor TStBarCodeInfo.Create;
begin
inherited Create;
FBars := TList.Create;
end;
destructor TStBarCodeInfo.Destroy;
begin
Clear;
FBars.Free;
FBars := nil;
inherited Destroy;
end;
function TStBarCodeInfo.GetBars(Index : Integer) : TStBarData;
begin
Result := FBars[Index];
end;
function TStBarCodeInfo.GetCount : Integer;
begin
Result := FBars.Count;
end;
{*** TStBarCode ***}
procedure TStBarCode.CalcBarCode;
var
I, J, X : Integer;
CheckC : Integer;
CheckK : Integer;
CSP : string;
C : string;
C1, C2 : string;
procedure AddCode(const S : string; AKind : TStBarKindSet);
var
I : Integer;
begin
for I := 1 to Length(S) do
if S[I] = '0' then
bcBarInfo.Add(1, AKind - [bkBar, bkThreeQuarterBar, bkHalfBar] + [bkSpace])
else
bcBarInfo.Add(StrToInt(S[I]), AKind);
end;
procedure AddECode(const Parity : string);
var
I : Integer;
begin
for I := 1 to Length(Parity) do begin
if Parity[I] = 'E' then
AddCode(UPC_E_EvenParity[bcDigits[I]], [bkBar])
else
AddCode(UPC_E_OddParity[bcDigits[I]], [bkBar]);
end;
end;
procedure AddSupCode(const Parity : string);
var
I : Integer;
begin
for I := 1 to Length(Parity) do begin
if Parity[I] = 'E' then
AddCode(UPC_E_EvenParity[bcDigits[I]], [bkThreeQuarterBar, bkSupplement])
else
AddCode(UPC_E_OddParity[bcDigits[I]], [bkThreeQuarterBar, bkSupplement]);
if I < Length(Parity) then
AddCode('01', [bkThreeQuarterBar, bkSupplement]);
end;
end;
procedure AddCodeModules(const S : string);
var
K : Integer;
begin
for K := 1 to Length(S) do begin
if Odd(K) then
bcBarInfo.Add(StrToInt(S[K]), [bkBar])
else
bcBarInfo.Add(StrToInt(S[K]), [bkSpace]);
end;
end;
procedure AddCodeWideNarrow(const S : string);
var
K : Integer;
begin
for K := 1 to Length(S) do begin
case S[K] of
'0' : if Odd(K) then
bcBarInfo.Add(1, [bkBar])
else
bcBarInfo.Add(1, [bkSpace]);
'1' : if Odd(K) then
bcBarInfo.Add(FBarNarrowToWideRatio, [bkBar])
else
bcBarInfo.Add(FBarNarrowToWideRatio, [bkSpace]);
end;
end;
end;
begin
if csLoading in ComponentState then
Exit;
bcBarInfo.Clear;
if Code = '' then
Exit;
{get copy of code}
C := Code;
{get digits}
case FBarCodeType of
bcUPC_A, bcUPC_E, bcEAN_8, bcEAN_13, bcCodabar, bcCode11, bcCode93 :
begin
bcDigitCount := GetDigits(C);
end;
bcInterleaved2of5 :
begin
{adjust odd length code}
if FAddCheckChar then begin
if not Odd(Length(C)) then
C := '0' + C;
end else begin
if Odd(Length(C)) then
C := '0' + C;
end;
bcDigitCount := GetDigits(C);
end;
bcCode39 :
begin
{add guard characters}
if C[1] <> '*' then
C := '*' + C;
if C[Length(C)] <> '*' then
C := C + '*';
bcDigitCount := GetDigits(C);
end;
bcCode128 :
begin
{add start code}
if not (C[1] in [#136, #137, #138]) then
case FCode128Subset of
csCodeA : C := #136 + C;
csCodeB : C := #137 + C;
csCodeC : C := #138 + C;
end;
bcDigitCount := GetDigits(C);
end;
end;
case FBarCodeType of
bcUPC_A :
begin
{get check digit}
if Length(C) = 11 then
GetCheckCharacters(C, CheckC, CheckK)
else
CheckC := bcDigits[12];
{encode left hand guard bars}
AddCode('101', [bkGuard, bkBar]);
{first six characters as left hand characters}
for I := 1 to 6 do
AddCode(UPC_A_LeftHand[bcDigits[I]], [bkBar]);
{center guard pattern}
AddCode('01010', [bkGuard, bkBar]);
{last five data characters as right hand characters}
for I := 7 to 11 do
AddCode(UPC_A_RightHand[bcDigits[I]], [bkBar]);
{check character}
AddCode(UPC_A_RightHand[CheckC], [bkBar]);
{encode right hand guard bars}
AddCode('101', [bkGuard, bkBar]);
end;
bcUPC_E :
begin
{encode left hand guard bars, 101}
AddCode('101', [bkGuard, bkBar]);
GetCheckCharacters(C, CheckC, CheckK);
case CheckC of
0 : AddECode('EEEOOO');
1 : AddECode('EEOEOO');
2 : AddECode('EEOOEO');
3 : AddECode('EEOOOE');
4 : AddECode('EOEEOO');
5 : AddECode('EOOEEO');
6 : AddECode('EOOOEE');
7 : AddECode('EOEOEO');
8 : AddECode('EOEOOE');
9 : AddECode('EOOEOE');
end;
{encode right hand guard bars}
AddCode('010101', [bkGuard, bkBar]);
end;
bcEAN_8 :
begin
{get check digit}
if Length(C) = 7 then
GetCheckCharacters(C, CheckC, CheckK)
else
CheckC := bcDigits[8];
{encode left hand guard bars}
AddCode('101', [bkGuard, bkBar]);
{two flag two data characters, encoded as left hand A characters}
for I := 1 to 4 do
AddCode(EAN_LeftHandA[bcDigits[I]], [bkBar]);
{encode center guard bars}
AddCode('01010', [bkGuard, bkBar]);
{last three data characters, encoded as right hand characters}
for I := 5 to 7 do
AddCode(UPC_A_RightHand[bcDigits[I]], [bkBar]);
{check character}
AddCode(UPC_A_RightHand[CheckC], [bkBar]);
{encode right hand guard bars}
AddCode('101', [bkGuard, bkBar]);
end;
bcEAN_13 :
begin
{get check digit}
if Length(C) = 12 then
GetCheckCharacters(C, CheckC, CheckK)
else
CheckC := bcDigits[13];
{determine which left hand table to use based on first flag character}
{EAN refers to this as the 13th digit - counting from the right}
case bcDigits[1] of
{ 12345}
0 : CSP := 'AAAAAA';
1 : CSP := 'AABABB';
2 : CSP := 'AABBAB';
3 : CSP := 'AABBBA';
4 : CSP := 'ABAABB';
5 : CSP := 'ABBAAB';
6 : CSP := 'ABBBAA';
7 : CSP := 'ABABAB';
8 : CSP := 'ABABBA';
9 : CSP := 'ABBABA';
end;
{encode left hand guard bars}
AddCode('101', [bkGuard, bkBar]);
{start with second flag character and next five data characters}
for I := 2 to 7 do
if CSP[I-1] = 'A' then
AddCode(EAN_LeftHandA[bcDigits[I]], [bkBar])
else
AddCode(EAN_LeftHandB[bcDigits[I]], [bkBar]);
{encode center guard bars}
AddCode('01010', [bkGuard, bkBar]);
{encode last five data characters}
for I := 8 to 12 do
AddCode(UPC_A_RightHand[bcDigits[I]], [bkBar]);
{check character}
AddCode(UPC_A_RightHand[CheckC], [bkBar]);
{encode right hand guard bars}
AddCode('101', [bkGuard, bkBar]);
end;
bcInterleaved2of5 :
begin
{add check character}
if FAddCheckChar then begin
{get check digit}
GetCheckCharacters(C, CheckC, CheckK);
Inc(bcDigitCount);
bcDigits[bcDigitCount] := CheckC;
end;
{encode left guard pattern}
bcBarInfo.Add(1, [bkGuard, bkBar]);
bcBarInfo.Add(1, [bkGuard, bkSpace]);
bcBarInfo.Add(1, [bkGuard, bkBar]);
bcBarInfo.Add(1, [bkGuard, bkSpace]);
I := 1;
while I < bcDigitCount do begin
{take two characters at a time - odd as bars, even as spaces}
C1 := Interleaved_2of5[bcDigits[I]];
C2 := Interleaved_2of5[bcDigits[I+1]];
{interleave data}
for J := 1 to 5 do begin
if C1[J] = '1' then
bcBarInfo.Add(FBarNarrowToWideRatio, [bkBar]) {wide bar}
else
bcBarInfo.Add(1, [bkBar]); {narrow bar}
if C2[J] = '1' then
bcBarInfo.Add(FBarNarrowToWideRatio, [bkSpace]){wide space}
else
bcBarInfo.Add(1, [bkSpace]); {narrow space}
end;
Inc(I, 2);
end;
{encode right guard pattern}
bcBarInfo.Add(FBarNarrowToWideRatio,
[bkGuard, bkBar]); {double-width bar}
bcBarInfo.Add(1, [bkGuard, bkSpace]);
bcBarInfo.Add(1, [bkGuard, bkBar]);
end;
bcCodabar :
begin
for I := 1 to bcDigitCount do begin
AddCodeWideNarrow(Codabar[bcDigits[I]]);
if I < bcDigitCount then
bcBarInfo.Add(1, [bkSpace]);
end;
end;
bcCode11 :
begin
AddCodeWideNarrow(Code11[11]); {start}
bcBarInfo.Add(1, [bkSpace]);
{add check characters}
if FAddCheckChar then begin
{get check digits}
GetCheckCharacters(C, CheckC, CheckK);
Inc(bcDigitCount);
bcDigits[bcDigitCount] := CheckC;
Inc(bcDigitCount);
bcDigits[bcDigitCount] := CheckK;
end;
for I := 1 to bcDigitCount do begin
AddCodeWideNarrow(Code11[bcDigits[I]]);
bcBarInfo.Add(1, [bkSpace]);
end;
AddCodeWideNarrow(Code11[11]); {stop}
end;
bcCode39 :
begin
for I := 1 to bcDigitCount do begin
C1 := Code39[bcDigits[I]];
for J := 1 to Length(C1) do begin
case C1[J] of
'0' : if Odd(J) then
bcBarInfo.Add(1, [bkBar])
else
bcBarInfo.Add(1, [bkSpace]);
'1' : if Odd(J) then
bcBarInfo.Add(2, [bkBar])
else
bcBarInfo.Add(2, [bkSpace]);
end;
end;
bcBarInfo.Add(1, [bkSpace]);
end;
end;
bcCode93 :
begin;
{start character}
AddCodeModules('111141');
{add check characters}
if FAddCheckChar then begin
{get check digits}
GetCheckCharacters(C, CheckC, CheckK);
Inc(bcDigitCount);
bcDigits[bcDigitCount] := CheckC;
Inc(bcDigitCount);
bcDigits[bcDigitCount] := CheckK;
end;
for I := 1 to bcDigitCount do
AddCodeModules(Code93[bcDigits[I]]);
{stop character}
AddCodeModules('1111411');
end;
bcCode128 :
begin
{add check character}
if FAddCheckChar then begin
GetCheckCharacters(C, CheckC, CheckK);
Inc(bcDigitCount);
bcDigits[bcDigitCount] := CheckC;
end;
{add stop code}
Inc(bcDigitCount);
bcDigits[bcDigitCount] := 106;
for I := 1 to bcDigitCount do
AddCodeModules(Code128[bcDigits[I]]);
end;
end;
if FBarCodeType in [bcUPC_A, bcUPC_E, bcEAN_8, bcEAN_13] then begin
{add supplemental encodings if requested}
if Length(FSupplementalCode) in [2, 5] then begin
{get digits}
bcDigitCount := GetDigits(FSupplementalCode);
{7 spaces after primary code - 0000000}
AddCode('0000000', [bkThreeQuarterBar, bkBlankSpace]);
{encode left hand guard bars, 1011}
AddCode('1011', [bkThreeQuarterBar, bkSupplement]);
if bcDigitCount = 2 then begin
{two digit supplement}
{determine parity table to use for each of the two characters}
X := bcDigits[1] * 10 + bcDigits[2];
case X mod 4 of
0 : AddSupCode('OO');
1 : AddSupCode('OE');
2 : AddSupCode('EO');
3 : AddSupCode('EE');
end;
end else begin
{five digit supplement}
{determine the parity pattern to use for each of the five}
X := ((bcDigits[1] + bcDigits[3] + bcDigits[5])*3 + (bcDigits[2] + bcDigits[4])*9) mod 10;
case X of
0 : AddSupCode('EEOOO');
1 : AddSupCode('EOEOO');
2 : AddSupCode('EOOEO');
3 : AddSupCode('EOOOE');
4 : AddSupCode('OEEOO');
5 : AddSupCode('OOEEO');
6 : AddSupCode('OOOEE');
7 : AddSupCode('OEOEO');
8 : AddSupCode('OEOOE');
9 : AddSupCode('OOEOE');
end;
end;
end;
end;
end;
procedure TStBarCode.CalcBarCodeWidth;
var
I : Integer;
begin
bcNormalWidth := 0;
bcSpaceWidth := 0;
bcSupplementWidth := 0;
for I := 0 to bcBarInfo.Count-1 do begin
if bkSpace in bcBarInfo[I].Kind then begin
if bkBlankSpace in bcBarInfo[I].Kind then
Inc(bcSpaceWidth, bcSpaceModWidth*bcBarInfo[I].Modules)
else if bkSupplement in bcBarInfo[I].Kind then
Inc(bcSupplementWidth, bcSpaceModWidth*bcBarInfo[I].Modules)
else
Inc(bcNormalWidth, bcSpaceModWidth*bcBarInfo[I].Modules)
end else begin
if bkBlankSpace in bcBarInfo[I].Kind then
Inc(bcSpaceWidth, bcBarModWidth*bcBarInfo[I].Modules)
else if bkSupplement in bcBarInfo[I].Kind then
Inc(bcSupplementWidth, bcBarModWidth*bcBarInfo[I].Modules)
else
Inc(bcNormalWidth, bcBarModWidth*bcBarInfo[I].Modules)
end;
end;
end;
procedure TStBarCode.CopyToClipboard;
var
{$IFNDEF FPC}
MetaFile : TMetaFile;
MetaFileCanvas : TMetaFileCanvas;
{$ENDIF}
Bitmap : TBitmap;
begin
Clipboard.Clear;
Clipboard.Open;
try
{bitmap}
Bitmap := TBitmap.Create;
try
Bitmap.Width := ClientWidth;
Bitmap.Height := ClientHeight;
PaintToDC(Bitmap.Canvas.Handle, ClientRect);
Clipboard.Assign(Bitmap);
{$IFNDEF FPC}
{metafile}
MetaFile := TMetaFile.Create;
try
MetaFileCanvas := TMetaFileCanvas.Create(MetaFile, 0);
try
MetaFile.Enhanced := True;
MetaFile.Width := ClientWidth;
MetaFile.Height := ClientHeight;
MetaFileCanvas.Draw(0, 0, Bitmap);
finally
MetaFileCanvas.Free;
end;
Clipboard.Assign(MetaFile);
finally
MetaFile.Free;
end;
{$ENDIF}
finally
Bitmap.Free;
end
finally
Clipboard.Close;
end;
end;
constructor TStBarCode.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
bcBarInfo := TStBarCodeInfo.Create;
{defaults}
Color := clWhite;
SetInitialBounds(0, 0, 200, 75);
FAddCheckChar := True;
FBarColor := clBlack;
FBarToSpaceRatio := 1;
FBarNarrowToWideRatio := bcDefNarrowToWideRatio;
FBarWidth := 12;
FShowCode := True;
FShowGuardChars := False;
FTallGuardBars := False;
FExtendedSyntax := False;
FCode := '123456789012';
CalcBarCode;
end;
destructor TStBarCode.Destroy;
begin
bcBarInfo.Free;
bcBarInfo := nil;
inherited Destroy;
end;
function TStBarCode.DrawBar(XPos, YPos, AWidth, AHeight : Integer) : Integer;
begin
Canvas.Rectangle(XPos, YPos, XPos+AWidth, YPos+AHeight);
Result := XPos + AWidth;
end;
procedure TStBarCode.DrawBarCode(const R : TRect);
var
I, X, Y : Integer;
CheckC : Integer;
CheckK : Integer;
TH, GA, TQ, BB : Integer;
BarCodeHeight : Integer;
BarCodeWidth : Integer;
PixelsPerInchX : Integer;
TR : TRect;
SmallestWidth : Double;
C : string;
Buf : array[0..512] of Char;
begin
Canvas.Brush.Color := FBarColor;
Canvas.Brush.Style := bsSolid;
PixelsPerInchX := GetDeviceCaps(Canvas.Handle, LOGPIXELSX);
{determine narrowest line width}
SmallestWidth := SmallestLineWidth(PixelsPerInchX);
{find sizes for the BarCode elements}
bcBarModWidth := Round(FBarWidth/1000 * PixelsPerInchX);
if bcBarModWidth < FBarToSpaceRatio then
bcBarModWidth := Round(BarToSpaceRatio);
if bcBarModWidth < SmallestWidth then
bcBarModWidth := Round(SmallestWidth);
bcSpaceModWidth := Round(bcBarModWidth / FBarToSpaceRatio);
{total width of BarCode and position within rect}
CalcBarCodeWidth;
BarCodeWidth := bcNormalWidth + bcSpaceWidth + bcSupplementWidth;
BarCodeHeight := RectHeight(R);
if BarCodeWidth < RectWidth(R) then
X := R.Left + (RectWidth(R)-BarCodeWidth) div 2
else
X := R.Left;
Y := R.Top;
{get text height}
TH := Canvas.TextHeight('Yg0');
{guard bar adjustment}
GA := (BarCodeHeight*10) div 100; {10% of bar height}
{but, not more than 1/4 of the font height}
if FShowCode and (GA > TH div 4) then
GA := TH div 4;
{three quarter height bar adjustment}
TQ := BarCodeHeight div 4;
{draw the text}
if FShowCode and (Code > '') then begin
C := Code;
{fill out invalid codes}
case FBarCodeType of
bcUPC_A :
begin
C := Copy(C, 1, 12); {truncate}
if Length(C) = 11 then begin
GetCheckCharacters(C, CheckC, CheckK);
C := C + IntToStr(CheckC);
end;
while Length(C) < 12 do
C := C + '0';
end;
bcUPC_E :
begin
C := Copy(C, 1, 6); {truncate}
while Length(C) < 6 do
C := C + '0';
end;
bcEAN_8 :
begin
C := Copy(C, 1, 8); {truncate}
if Length(C) = 7 then begin
GetCheckCharacters(C, CheckC, CheckK);
C := C + IntToStr(CheckC);
end;
while Length(C) < 8 do
C := C + '0';
end;
bcEAN_13 :
begin
C := Copy(C, 1, 13); {truncate}
if Length(C) = 12 then begin
GetCheckCharacters(C, CheckC, CheckK);
C := C + IntToStr(CheckC);
end;
while Length(C) < 13 do
C := C + '0';
end;
bcInterleaved2of5 :
begin
if Odd(Length(C)) then
C := '0' + C;
end;
bcCodabar :
begin
if not FShowGuardChars then
{strip leading and trailing characters}
C := Copy(C, 2, Length(C)-2);
end;
bcCode11 :
begin
end;
bcCode39 :
begin
{add guard characters}
if C[1] <> '*' then
C := '*' + C;
if C[Length(C)] <> '*' then
C := C + '*';
if not FShowGuardChars then
{strip leading and trailing characters}
C := Copy(C, 2, Length(C)-2);
end;
bcCode93 :
begin
{remove non-printable characters}
for I := 1 to Length(C) do
if C[I] < ' ' then
C[I] := ' ';
end;
bcCode128 :
begin
{remove non-printable characters}
I := 1;
while I <= Length (C) do begin
if C[I] < ' ' then
C[I] := ' ';
if (i < Length (C)) and (ExtendedSyntax) then begin
if (C[I] = '\') and
(C[I + 1] in ['A', 'B', 'C', 'a', 'b', 'c']) then begin
C[I] := ' ';
C[I + 1] := ' ';
Inc (I);
end else if (C[I] = '\') and (C[I+1] = '\') then begin
C[I] := ' ';
Inc (I);
end;
end;
Inc (I);
end;
end;
end;
Dec(BarCodeHeight, TH + (TH div 4));
Canvas.Brush.Style := bsClear;
{guard bar adjustment - again}
GA := (BarCodeHeight*10) div 100; {10% of bar height}
{but, not more than 1/4 of the font height}
if FShowCode and (GA > TH div 4) then
GA := TH div 4;
{three quarter height bar adjustment}
TQ := BarCodeHeight div 4;
if FBarCodeType = bcUPC_A then begin
{print first and last character to sides of symbol}
TR.Top := Y;
TR.Bottom := TR.Top + BarCodeHeight;
{left hand character}
Buf[0] := C[1];
TR.Right := X;
TR.Left := X - 2 * Canvas.TextWidth(C[1]);
DrawText(Canvas.Handle, @Buf, 1, TR, DT_BOTTOM or DT_CENTER or DT_SINGLELINE);
{remove character from code to print}
C := Copy(C, 2, Length(C)-1);
{right hand character - if no supplemental code}
if FSupplementalCode = '' then begin
Buf[0] := C[Length(C)];
TR.Left := X + bcNormalWidth;
TR.Right := X + bcNormalWidth + 2 * Canvas.TextWidth(C[Length(C)]);
DrawText(Canvas.Handle, @Buf, 1, TR, DT_BOTTOM or DT_CENTER or DT_SINGLELINE);
{remove character from code to print}
C := Copy(C, 1, Length(C)-1);
end;
end;
if FSupplementalCode > '' then begin
{draw supplemental code above the code}
TR.Top := Y + TQ - TH;
TR.Bottom := Y + BarCodeHeight;
TR.Left := X + bcNormalWidth + bcSpaceWidth;
TR.Right := TR.Left + bcSupplementWidth;
StrPLCopy(Buf, FSupplementalCode, Length(Buf)-1);
DrawText(Canvas.Handle, @Buf, StrLen(Buf), TR, DT_VCENTER or DT_CENTER);
end;
TR := R;
TR.Top := R.Top + BarCodeHeight + (TH div 4);
TR.Left := X;
TR.Right := TR.Left + bcNormalWidth;
Canvas.Brush.Style := bsClear;
StrPLCopy(Buf, C, Length(Buf)-1);
DrawText(Canvas.Handle, @Buf, StrLen(Buf), TR, DT_VCENTER or DT_CENTER);
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := FBarColor;
end;
if (FBarCodeType = bcInterleaved2of5) and FBearerBars then begin
BB := 3 * bcBarModWidth;
{reduce height to allow for bearer bars}
Dec(BarCodeHeight, BB * 2);
{draw the bearer bars}
Canvas.Rectangle(X-bcBarModWidth, Y,
X+BarCodeWidth+bcBarModWidth, Y+BB);
Canvas.Rectangle(X-bcBarModWidth, Y+BarCodeHeight+BB,
X+BarCodeWidth+bcBarModWidth, Y+BarCodeHeight+BB*2);
{adjust top of BarCode}
Inc(Y, BB);
end;
{draw the bar code}
for I := 0 to bcBarInfo.Count-1 do begin
if bkSpace in bcBarInfo[I].Kind then
Inc(X, bcSpaceModWidth*bcBarInfo[I].Modules)
else if (bkGuard in bcBarInfo[I].Kind) and FTallGuardBars then begin
if bcGuardBarAbove and bcGuardBarBelow then
X := DrawBar(X, Y-GA, bcBarModWidth*bcBarInfo[I].Modules, BarCodeHeight+2*GA)
else if bcGuardBarAbove then
X := DrawBar(X, Y-GA, bcBarModWidth*bcBarInfo[I].Modules, BarCodeHeight+GA)
else if bcGuardBarBelow then
X := DrawBar(X, Y, bcBarModWidth*bcBarInfo[I].Modules, BarCodeHeight+2*GA)
end else if (bkBar in bcBarInfo[I].Kind) or (bkGuard in bcBarInfo[I].Kind) then
X := DrawBar(X, Y, bcBarModWidth*bcBarInfo[I].Modules, BarCodeHeight)
else if (bkThreeQuarterBar in bcBarInfo[I].Kind) then
X := DrawBar(X, Y+TQ, bcBarModWidth*bcBarInfo[I].Modules, BarCodeHeight-TQ);
end;
end;
{added}
function TStBarCode.GetBarCodeWidth(ACanvas : TCanvas) : Double;
var
PixelsPerInchX : Integer;
SmallestWidth : Double;
begin
PixelsPerInchX := GetDeviceCaps(ACanvas.Handle, LOGPIXELSX);
{determine narrowest line width}
SmallestWidth := SmallestLineWidth(PixelsPerInchX);
{find sizes for the BarCode elements}
bcBarModWidth := Round(FBarWidth/1000 * PixelsPerInchX);
if bcBarModWidth < FBarToSpaceRatio then
bcBarModWidth := Round(BarToSpaceRatio);
if bcBarModWidth < SmallestWidth then
bcBarModWidth := Round(SmallestWidth);
bcSpaceModWidth := Round(bcBarModWidth / FBarToSpaceRatio);
CalcBarcodeWidth;
{width in pixels (not counting text printed to left or right of code)}
Result := bcNormalWidth + bcSpaceWidth + bcSupplementWidth;
{return width of barcode in inches}
Result := Result / PixelsPerInchX;
end;
procedure TStBarCode.GetCheckCharacters(const S : string; var C, K : Integer);
var
I : Integer;
C1 : Integer;
C2 : Integer;
St : string;
begin
C := -1;
K := -1;
St := S;
case FBarCodeType of
bcUPC_A :
begin
if Length(St) >= 11 then begin
{get digits}
GetDigits(St);
{determine check character}
C1 := (bcDigits[1] + bcDigits[3] + bcDigits[5] + bcDigits[7] +
bcDigits[9] + bcDigits[11]) * 3;
C2 := bcDigits[2] + bcDigits[4] + bcDigits[6] +
bcDigits[8] + bcDigits[10];
C := 10 - ((C1 + C2) mod 10);
if C = 10 then
C := 0;
end;
end;
bcUPC_E :
begin
{get digits}
GetDigits(St);
{determine check character}
C1 := (bcDigits[2] + bcDigits[4] + bcDigits[6]) * 3;
C2 := bcDigits[1] + bcDigits[3] + bcDigits[5];
C := 10 - ((C1 + C2) mod 10);
if C = 10 then
C := 0;
end;
bcEAN_8 :
begin
if Length(St) >= 7 then begin
{get digits}
GetDigits(St);
{determine check character}
C1 := (bcDigits[1] + bcDigits[3] + bcDigits[5] + bcDigits[7]) * 3;
C2 := bcDigits[2] + bcDigits[4] + bcDigits[6];
C := 10 - ((C1 + C2) mod 10);
if C = 10 then
C := 0;
end;
end;
bcEAN_13 :
begin
if Length(St) >= 12 then begin
{get digits}
GetDigits(St);
{determine check character}
C1 := (bcDigits[2] + bcDigits[4] + bcDigits[6] + bcDigits[8] +
bcDigits[10] + bcDigits[12]) * 3;
C2 := bcDigits[1] + bcDigits[3] + bcDigits[5] + bcDigits[7] +
bcDigits[9] + bcDigits[11];
C := 10 - ((C1 + C2) mod 10);
if C = 10 then
C := 0;
end;
end;
bcInterleaved2of5 :
begin
{get digits}
bcDigitCount := GetDigits(St);
C1 := 0;
C2 := 0;
for I := 1 to bcDigitCount do
if Odd(I) then
C1 := C1 + bcDigits[I] {odd digits}
else
C2 := C2 + bcDigits[I]; {even digits}
C2 := C2 * 3;
C := 10 - ((C1 + C2) mod 10);
if C = 10 then
C := 0;
end;
bcCodabar :
begin
{get digits}
bcDigitCount := GetDigits(St);
C1 := 0;
for I := 1 to bcDigitCount do
C1 := C1 + bcDigits[I];
C := 16 - (C1 mod 16);
if C = 16 then
C := 0;
end;
bcCode11 :
begin
{get digits}
bcDigitCount := GetDigits(St);
C1 := 0;
for I := bcDigitCount downto 1 do
C1 := C1 + bcDigits[I]*(bcDigitCount-I+1);
C1 := C1 mod 11; {the "C" check character}
C2 := C1;
for I := bcDigitCount downto 1 do
C2 := C2 + bcDigits[I]*(bcDigitCount-I+2);
C2 := C2 mod 11; {the "K" check character}
K := C2;
C := C1;
end;
bcCode39 :
begin
{get digits}
bcDigitCount := GetDigits(St);
C1 := 0;
for I := 1 to bcDigitCount do
C1 := C1 + bcDigits[I];
C := 43 - (C1 mod 43);
if C = 43 then
C := 0;
end;
bcCode93 :
begin
{get digits}
bcDigitCount := GetDigits(St);
C1 := 0;
for I := bcDigitCount downto 1 do
C1 := C1 + bcDigits[I]*(bcDigitCount-I+1);
C1 := C1 mod 47; {the "C" check character}
C2 := C1;
for I := bcDigitCount downto 1 do
C2 := C2 + bcDigits[I]*(bcDigitCount-I+2);
C2 := C2 mod 47; {the "K" check character}
K := C2;
C := C1;
end;
bcCode128 :
begin
{get digits}
bcDigitCount := GetDigits(St);
C1 := bcDigits[1];
for I := 2 to bcDigitCount do
C1 := C1 + bcDigits[I]*(I-1);
C := C1 mod 103;
if C = 103 then
C := 0;
end;
end;
end;
function TStBarCode.GetDigits(Characters : string) : Integer;
procedure GetACode128CDigit (c : Char; var Index : Integer;
var bcDigitPos : Integer);
var
J : Integer;
begin
case (c) of
#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
try
J := StrToInt (Copy (Characters, Index, 2));
bcDigits[bcDigitPos + 1] := J;
Inc (Index);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
end;
Inc (Index);
Inc (bcDigitPos);
end;
procedure GetACode128ABDigit (c : Char; var Index : Integer;
var bcDigitPos : Integer);
begin
case c of
' ' : bcDigits[bcDigitPos + 1] := 0;
'!' : bcDigits[bcDigitPos + 1] := 1;
'"' : bcDigits[bcDigitPos + 1] := 2;
'#' : bcDigits[bcDigitPos + 1] := 3;
'$' : bcDigits[bcDigitPos + 1] := 4;
'%' : bcDigits[bcDigitPos + 1] := 5;
'&' : bcDigits[bcDigitPos + 1] := 6;
'''' : bcDigits[bcDigitPos + 1] := 7;
'(' : bcDigits[bcDigitPos + 1] := 8;
')' : bcDigits[bcDigitPos + 1] := 9;
'*' : bcDigits[bcDigitPos + 1] := 10;
'+' : bcDigits[bcDigitPos + 1] := 11;
',' : bcDigits[bcDigitPos + 1] := 12;
'-' : bcDigits[bcDigitPos + 1] := 13;
'.' : bcDigits[bcDigitPos + 1] := 14;
'/' : bcDigits[bcDigitPos + 1] := 15;
'0'..'9' : bcDigits[bcDigitPos + 1] := 16 + Ord(c)-Ord('0');
':' : bcDigits[bcDigitPos + 1] := 26;
';' : 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;
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.SetBarNarrowToWideRatio(Value : Integer);
begin
if Value <> FBarNarrowToWideRatio then begin
FBarNarrowToWideRatio := Value;
CalcBarCode;
Invalidate;
end;
end;
procedure TStBarCode.SetBarWidth(Value : Double);
begin
if Value <> FBarWidth then begin
FBarWidth := Value;
Invalidate;
end;
end;
procedure TStBarCode.SetBearerBars(Value : Boolean);
begin
if Value <> FBearerBars then begin
FBearerBars := Value;
Invalidate;
end;
end;
procedure TStBarCode.SetCode(const AValue : string);
begin
if FBarCodeType in [bcCode39] then
FCode := UpperCase(AValue)
else if FBarCodeType in [bcCodabar] then
FCode := LowerCase(AValue)
else
FCode := AValue;
CalcBarCode;
Invalidate;
end;
procedure TStBarCode.SetCode128Subset(Value : TStCode128CodeSubset);
begin
if Value <> FCode128Subset then begin
FCode128Subset := Value;
CalcBarCode;
Invalidate;
end;
end;
procedure TStBarCode.SetExtendedSyntax (const v : Boolean);
begin
if v <> FExtendedSyntax then begin
FExtendedSyntax := v;
CalcBarCode;
Invalidate;
end;
end;
procedure TStBarCode.SetShowCode(Value : Boolean);
begin
if Value <> FShowCode then begin
FShowCode := Value;
Invalidate;
end;
end;
procedure TStBarCode.SetShowGuardChars(Value : Boolean);
begin
if Value <> FShowGuardChars then begin
FShowGuardChars := Value;
Invalidate;
end;
end;
procedure TStBarCode.SetSupplementalCode(const Value : string);
begin
if Value <> FSupplementalCode then begin
FSupplementalCode := Value;
CalcBarCode;
Invalidate;
end;
end;
procedure TStBarCode.SetTallGuardBars(Value : Boolean);
begin
if Value <> FTallGuardBars then begin
FTallGuardBars := Value;
Invalidate;
end;
end;
procedure TStBarCode.SetVersion(const Value : string);
begin
end;
function TStBarCode.SmallestLineWidth(PixelsPerInch : Integer) : Double;
begin
Result := PixelsPerInch * 0.010; {10 mils}
if Result < 1 then
Result := 1;
end;
function TStBarCode.Validate(DisplayError : Boolean) : Boolean;
var
I : Integer;
CheckC : Integer;
CheckK : Integer;
begin
Result := True;
try
case FBarCodeType of
bcUPC_A :
begin
{11 or 12 characters}
if not (Length(Code) in [11, 12]) then
RaiseStError(EStBarCodeError, stscInvalidUPCACodeLen);
try
GetDigits(Code);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
GetCheckCharacters(Code, CheckC, CheckK);
if (Length(Code) = 12) and (CheckC <> bcDigits[12]) then
RaiseStError(EStBarCodeError, stscInvalidCheckCharacter);
end;
bcUPC_E :
begin
{6 characters}
if not (Length(Code) = 6) then
RaiseStError(EStBarCodeError, stscInvalidUPCACodeLen);
try
GetDigits(Code);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
end;
bcEAN_8 :
begin
{7 or 8 characters}
if not (Length(Code) in [7, 8]) then
RaiseStError(EStBarCodeError, stscInvalidEAN8CodeLen);
try
GetDigits(Code);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
GetCheckCharacters(Code, CheckC, CheckK);
if (Length(Code) = 8) and (CheckC <> bcDigits[8]) then
RaiseStError(EStBarCodeError, stscInvalidCheckCharacter);
end;
bcEAN_13 :
begin
{12 or 13 characters}
if not (Length(Code) in [12, 13]) then
RaiseStError(EStBarCodeError, stscInvalidEAN13CodeLen);
try
GetDigits(Code);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
GetCheckCharacters(Code, CheckC, CheckK);
if (Length(Code) = 13) and (CheckC <> bcDigits[13]) then
RaiseStError(EStBarCodeError, stscInvalidCheckCharacter);
end;
bcInterleaved2of5 :
begin
try
GetDigits(Code);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
end;
bcCodabar :
begin
for I := 1 to Length(Code) do
if not (Code[I] in ['0'..'9', '-', '$', ':', '/', '.', '+', 'a'..'d', 'A'..'D']) then
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
bcCode11 :
begin
for I := 1 to Length(Code) do
if not (Code[I] in ['0'..'9', '-']) then
RaiseStError(EStBarCodeError, stscInvalidCharacter);
{test check characters}
if not FAddCheckChar then begin
GetCheckCharacters(Code, CheckC, CheckK);
if (StrToInt(Code[Length(Code)-1]) <> CheckC) or
(StrToInt(Code[Length(Code)]) <> CheckK) then
RaiseStError(EStBarCodeError, stscInvalidCheckCharacter);
end;
end;
bcCode39 :
begin
for I := 1 to Length(Code) do
if not (Code[I] in ['0'..'9', 'A'..'Z', 'a'..'z',
'-', '.', ' ', '$', '/', '+', '%', '*']) then
RaiseStError(EStBarCodeError, stscInvalidCharacter);
{check for embedded guard character}
for I := 2 to Length(Code)-1 do
if Code[I] = '*' then
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
bcCode93 :
begin
try
GetCheckCharacters(Code, CheckC, CheckK);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
end;
bcCode128 :
begin
try
GetCheckCharacters(Code, CheckC, CheckK);
except
RaiseStError(EStBarCodeError, stscInvalidCharacter);
end;
end;
end;
{check supplemental code}
if FSupplementalCode > '' then
if not (Length(FSupplementalCode) in [2, 5]) then
RaiseStError(EStBarCodeError, stscInvalidSupCodeLen);
except
Result := False;
if DisplayError then
raise;
end;
end;
end.
Reference in New Issue Copy Permalink