tpsystools_4.04/source/StBarPN.pas

// 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: StBarPN.pas 4.04                            *}
{*********************************************************}
{* SysTools: PostNet Bar Code component                  *}
{*********************************************************}

{$I StDefine.inc}

unit StBarPN;

interface

uses
  Windows, Classes, ClipBrd, Controls, Graphics, Messages, SysUtils,
  StBase, StConst, StStrL;

type
  TStPNBarCodeDims = packed record
    PixPerBar        : Longint;
    PixPerSpace      : Longint;
    ShortBarHeight   : Longint;
    TallBarHeight    : Longint;
    Width            : Longint;
    Height           : Longint;
  end;

  TStPNBarCodeRes = packed record
    XRes  : Longint;
    YRes  : Longint;
  end;

  TStPNBarCode = class(TGraphicControl)
  protected {private}
    {property variables}
    FPostalCode        : string;
    FCheckNumber       : Integer;


    {internal variables}
    pnbcDisplayDims    : TStPNBarCodeDims;
    pnbcDefRes         : TStPNBarCodeRes;

    {property methods}
    function  GetVersion : string;
    procedure SetPostalCode(Value : String);
    procedure SetVersion (const v : string);

    {internal methods}
    function DrawTallBar(C         : TCanvas;
                         Dims      : TStPNBarCodeDims;
                         XPos      : Integer;
                         AddSpace  : Boolean) : Longint;
    function DrawShortBar(C        : TCanvas;
                          Dims     : TStPNBarCodeDims;
                          XPos     : Integer;
                          AddSpace : Boolean) : Longint;
    function DrawNumber(C          : TCanvas;
                        Dims       : TStPNBarCodeDims;
                        Value      : Integer;
                        XPos       : Longint;
                        FrontGuard : Boolean;
                        EndGuard   : Boolean) : Longint;
    procedure DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
    procedure SetCheckNumber;

(*
    procedure CMTextChanged(var Msg : TMessage);
      message CM_TEXTCHANGED;
*)

  protected
    procedure Loaded; override;
    procedure Paint; override;
  public
    constructor Create(AOwner : TComponent); override;

    procedure ComputeSizes(C        : TCanvas;
                           Res      : TStPNBarCodeRes;
                           var Dims : TStPNBarCodeDims);
    procedure CopyToClipboard;
    procedure PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
    procedure PaintToDC(DC : hDC; Position : TPoint);
    procedure PaintToPrinterCanvas(ACanvas : TCanvas; Position : TPoint);
    procedure PaintToPrinterDC(DC : hDC; Position : TPoint);
    procedure SaveToFile(ACanvas : TCanvas; const FileName : string);
    procedure SaveToFileRes(Res : TStPNBarCodeRes; const FileName : string);

  published
    {properties}
    property Cursor;
    property Enabled;
    property Hint;
    property ParentShowHint;
    property ShowHint;
    property Visible;

    property PostalCode : string read FPostalCode write SetPostalCode;

    property Version : string read GetVersion write SetVersion stored False;

    {events}
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;


implementation

{*** TStPNBarCode ***}

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


procedure TStPNBarCode.SetVersion(const v : string);
begin
end;

constructor TStPNBarCode.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);

  {defaults}
  pnbcDefRes.XRes := 0;
  pnbcDefRes.YRes := 0;
{set arbitrary values for height/width so that component automatically resizes}
  Height := 10;
  Width  := 10;
  PostalCode := '12345';
  SetCheckNumber;
end;


procedure TStPNBarCode.Loaded;
begin
  inherited Loaded;
  Invalidate;
end;


procedure TStPNBarCode.Paint;
begin
  ComputeSizes(Canvas, pnbcDefRes, pnbcDisplayDims);
  Height := pnbcDisplayDims.Height;
  Width  := pnbcDisplayDims.Width;
  DrawBarCode(Canvas, pnbcDisplayDims);
end;


procedure TStPNBarCode.SetCheckNumber;
var
  I : Longint;
begin
  if (Length(TrimL(FPostalCode)) < 5) then Exit;
  FCheckNumber := 0;
  for I := 1 to Length(FPostalCode) do
    FCheckNumber := FCheckNumber + StrToInt(FPostalCode[I]);
  I := FCheckNumber mod 10;
  if (I > 0) then
    FCheckNumber := 10 - I
  else
    FCheckNumber := 0;
end;

procedure TStPNBarCode.SetPostalCode(Value : string);
var
  I : Integer;
  Local : string;                                                        
begin
  if (csLoading in ComponentState) then Exit;

  Local := TrimL(Value);                                                 

  {strip non-numerics}
  I := 1;
  repeat
    if not (Local[I] in ['0'..'9']) then
      System.Delete(Local, I, 1)
    else
      Inc(I);
  until (I > Length(Local));

  { looks like a valid Postal Code?}
  if (Local <> FPostalCode) then begin                                   
     if (Length(Local) in [5, 9, 11]) then begin                         
      FPostalCode := Local;
      SetCheckNumber;
      Invalidate;
    end else
      RaiseStError(EStPNBarCodeError, stscInvalidLength);
  end; { else it's the same code, don't bother updating }
end;


function TStPNBarCode.DrawTallBar(C        : TCanvas;
                                  Dims     : TStPNBarCodeDims;
                                  XPos     : Integer;
                                  AddSpace : Boolean) : Longint;
var
  YPos : Longint;
begin
  Result := XPos;
  YPos := Dims.Height - 5 - Dims.TallBarHeight;
  C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.TallBarHeight);
  Result := Result + Dims.PixPerBar;

  if (AddSpace) then
    Inc(Result, Dims.PixPerSpace);
end;


function TStPNBarCode.DrawShortBar(C        : TCanvas;
                                   Dims     : TStPNBarCodeDims;
                                   XPos     : Integer;
                                   AddSpace : Boolean) : Longint;
var
  YPos : Longint;
begin
  Result := XPos;
  YPos := Dims.Height - 5 - Dims.ShortBarHeight;
  C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.ShortBarHeight);
  Result := Result + Dims.PixPerBar;

  if (AddSpace) then
    Inc(Result, Dims.PixPerSpace);
end;


function TStPNBarCode.DrawNumber(C          : TCanvas;
                                 Dims       : TStPNBarCodeDims;
                                 Value      : Integer;
                                 XPos       : Longint;
                                 FrontGuard : Boolean;
                                 EndGuard   : Boolean) : Longint;
begin
  Result := XPos;
  if (FrontGuard) then
    Result := DrawTallBar(C, Dims, Result, True);

  case Value of
    0 : begin
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
        end;

    1 : begin
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
        end;

    2 : begin
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
        end;

    3 : begin
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
        end;

    4 : begin
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
        end;

    5 : begin
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
        end;

    6 : begin
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
        end;

    7 : begin
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
        end;

    8 : begin
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
        end;

    9 : begin
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawTallBar(C,  Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
          Result := DrawShortBar(C, Dims, Result, True);
        end;
  end;

  if (EndGuard) then
    Result := DrawTallBar(C, Dims, Result, False);
end;


procedure TStPNBarCode.ComputeSizes(C        : TCanvas;
                                    Res      : TStPNBarCodeRes;
                                    var Dims : TStPNBarCodeDims);
var
  PPIX,
  PPIY   : Longint;
begin
  if csLoading in ComponentState then
    Exit;
  {get resolution}
  if ((Res.XRes > 0) and (Res.YRes > 0)) then begin
    PPIX := Res.XRes;
    PPIY := Res.YRes;
  end else begin
    PPIX := GetDeviceCaps(C.Handle, LOGPIXELSX);
    PPIY := GetDeviceCaps(C.Handle, LOGPIXELSY);
  end;

  {PN bar is 0.015" to 0.025" - use mid value}
  {add 1 since Canvas.Rectangle draws 1 pixel less than Width}
  Dims.PixPerBar := Round(PPIX * 0.017) + 1;

  {CenterLine distance is 0.0416" to 0.0500". Space is that minus width of bar}
  {In all cases the Pitch must be 22 +/-2 bars/Inch where a bar is the bar and}
  {the trailing space}

  {add 1 since Canvas.Rectangle draws 1 pixel less than Width}
  Dims.PixPerSpace := Round(0.0475 * PPIX) - Dims.PixPerBar + 1;

  {max height of short bar is 0.050" +/-0.010". To allow for 75dpi, go a}
  {little less}
  {add 1 since Canvas.Rectangle draws 1 pixel less than Height}
  Dims.ShortBarHeight := Round(0.047 * PPIY) + 1;

  {max height of tall bar is 0.125" +/-0.010". To allow for 75dpi, go a}
  {little less}
  {add 1 since Canvas.Rectangle draws 1 pixel less than Height}
  Dims.TallBarHeight := Round(0.122 * PPIY) + 1;


  {Total Width of Canvas =
     FrontGuardBar + Space +
     (NumberChars + CheckChar) * (5 * (PixelsPerBar + PixelsPerSpace)) +
     (EndBar w/o Space) +
     5 pixels left/right margin
  }
  Dims.Width :=
    (Dims.PixPerBar + Dims.PixPerSpace) +
    (Length(PostalCode) + 1) * (5 * (Dims.PixPerBar + Dims.PixPerSpace)) +
    Dims.PixPerBar + 10;

  {Height = Height of tall bar + 3 pixel top/bottom margin}
  Dims.Height := Dims.TallBarHeight + 3;
end;


procedure TStPNBarCode.DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
var
  I,
  XPos : Longint;
begin
  if csLoading in ComponentState then
    Exit;

  C.Brush.Color := clBlack;
  C.Brush.Style := bsSolid;

  {Draw the Code}
  XPos := 5;
  XPos := DrawNumber(C, Dims, StrToInt(PostalCode[1]), XPos, True, False);
  for I := 2 to Length(PostalCode) do
    XPos := DrawNumber(C, Dims, StrToInt(PostalCode[I]), XPos, False, False);
  DrawNumber(C, Dims, FCheckNumber, XPos, False, True);
end;


(*
procedure TStPNBarCode.CMTextChanged(var Msg : TMessage);
begin
  SetCheckNumber;
  Invalidate;
end;
*)

procedure TStPNBarCode.CopyToClipboard;
var
  MetaFile       : TMetaFile;
  MetaFileCanvas : TMetaFileCanvas;
  Bitmap         : TBitmap;
  Dims           : TStPNBarCodeDims;
begin
  Clipboard.Clear;
  Clipboard.Open;
  try
    {bitmap}
    Bitmap := TBitmap.Create;
    try
      ComputeSizes(Bitmap.Canvas, pnbcDefRes, Dims);
      Bitmap.Width  := Dims.Width;
      Bitmap.Height := Dims.Height;
      DrawBarCode(Bitmap.Canvas, Dims);
      Clipboard.Assign(Bitmap);

      {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;

    finally
      Bitmap.Free;
    end
  finally
    Clipboard.Close;
  end;
end;


procedure TStPNBarCode.PaintToDC(DC : hDC; Position : TPoint);
var
  Bmp     : TBitmap;
  ACanvas : TCanvas;
  Dims    : TStPNBarCodeDims;
  R1,
  R2      : TRect;
begin
  ACanvas := TCanvas.Create;
  ACanvas.Handle := DC;
  Bmp := TBitmap.Create;
  try
    ComputeSizes(ACanvas, pnbcDefRes, Dims);
    Bmp.Height := Dims.Height;
    Bmp.Width  := Dims.Width;
    R1 := Rect(0, 0, Dims.Width, Dims.Height);
    R2 := Rect(Position.X, Position.Y,
               Dims.Width + Position.X,
               Dims.Height + Position.Y);

    DrawBarCode(Bmp.Canvas, Dims);
    ACanvas.CopyRect(R2, Bmp.Canvas, R1);
  finally
    Bmp.Free;
    ACanvas.Free;
  end;
end;


procedure TStPNBarCode.PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
begin
  PaintToDC(ACanvas.Handle, Position);
end;


procedure TStPNBarCode.PaintToPrinterCanvas(ACanvas : TCanvas;
                                            Position : TPoint);
begin
  PaintToPrinterDC(ACanvas.Handle, Position);
end;


procedure TStPNBarCode.PaintToPrinterDC(DC : hDC; Position : TPoint);
var
  Bmp       : TBitmap;
  ACanvas   : TCanvas;
  Dims      : TStPNBarCodeDims;
  R1,
  R2        : TRect;

  Info      : PBitMapInfo;
  InfoSize  : DWORD;
  ImageSize : DWORD;
  Image     : Pointer;
begin
  ACanvas := TCanvas.Create;
  Bmp     := TBitmap.Create;
  ACanvas.Handle := DC;
  try
    ComputeSizes(ACanvas, pnbcDefRes, Dims);
    Bmp.Height := Dims.Height;
    Bmp.Width  := Dims.Width;
    R1 := Rect(0, 0, Dims.Width, Dims.Height);
    R2 := Rect(Position.X, Position.Y,
               Dims.Width + Position.X,
               Dims.Height + Position.Y);

    DrawBarCode(Bmp.Canvas, Dims);

    {Delphi does not allow a simple Canvas.CopyRect to the printer Canvas}
    with Bmp do begin
        GetDIBSizes(Handle, InfoSize, ImageSize);
        GetMem(Info, InfoSize);
        try
          GetMem(Image, ImageSize);
          try
            GetDIB(Handle, Palette, Info^, Image^);
            with Info^.bmiHeader do begin
              StretchDIBits(ACanvas.Handle,
                            R2.Left, R2.Top, Dims.Width, Dims.Height,
                            0, 0, biWidth, biHeight,
                            Image, Info^, DIB_RGB_COLORS, SRCCOPY);
            end;
          finally
            FreeMem(Image, ImageSize)
          end;
        finally
          FreeMem(Info, InfoSize);
        end;
      end;
  finally
    Bmp.Free;
    ACanvas.Free;
  end;
end;


procedure TStPNBarCode.SaveToFile(ACanvas : TCanvas;
                                  const FileName : string);
var
  Bmp          : TBitmap;
  Dims         : TStPNBarCodeDims;
begin
  Bmp := TBitmap.Create;
  try
    ComputeSizes(ACanvas, pnbcDefRes, Dims);
    Bmp.Height := Dims.Height;
    Bmp.Width  := Dims.Width;
    DrawBarCode(Bmp.Canvas, Dims);
    Bmp.SaveToFile(FileName);
  finally
    Bmp.Free;
  end;
end;


procedure TStPNBarCode.SaveToFileRes(Res : TStPNBarCodeRes;
                                     const FileName : string);
var
  Bmp          : TBitmap;
  Dims         : TStPNBarCodeDims;
begin
  Bmp := TBitmap.Create;
  try
    ComputeSizes(Bmp.Canvas, Res, Dims);
    Bmp.Height := Dims.Height;
    Bmp.Width  := Dims.Width;
    DrawBarCode(Bmp.Canvas, Dims);
    Bmp.SaveToFile(FileName);
  finally
    Bmp.Free;
  end;
end;

end.
1	// Upgraded to Delphi 2009: Sebastian Zierer
2
3	(* *** BEGIN LICENSE BLOCK ***
4	* Version: MPL 1.1
5	*
6	* The contents of this file are subject to the Mozilla Public License Version
7	* 1.1 (the "License"); you may not use this file except in compliance with
8	* the License. You may obtain a copy of the License at
9	* http://www.mozilla.org/MPL/
10	*
11	* Software distributed under the License is distributed on an "AS IS" basis,
12	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13	* for the specific language governing rights and limitations under the
14	* License.
15	*
16	* The Original Code is TurboPower SysTools
17	*
18	* The Initial Developer of the Original Code is
19	* TurboPower Software
20	*
21	* Portions created by the Initial Developer are Copyright (C) 1996-2002
22	* the Initial Developer. All Rights Reserved.
23	*
24	* Contributor(s):
25	*
26	* *** END LICENSE BLOCK *** *)
27
28	{*********************************************************}
29	{* SysTools: StBarPN.pas 4.04 *}
30	{*********************************************************}
31	{* SysTools: PostNet Bar Code component *}
32	{*********************************************************}
33
34	{$I StDefine.inc}
35
36	unit StBarPN;
37
38	interface
39
40	uses
41	Windows, Classes, ClipBrd, Controls, Graphics, Messages, SysUtils,
42	StBase, StConst, StStrL;
43
44	type
45	TStPNBarCodeDims = packed record
46	PixPerBar : Longint;
47	PixPerSpace : Longint;
48	ShortBarHeight : Longint;
49	TallBarHeight : Longint;
50	Width : Longint;
51	Height : Longint;
52	end;
53
54	TStPNBarCodeRes = packed record
55	XRes : Longint;
56	YRes : Longint;
57	end;
58
59	TStPNBarCode = class(TGraphicControl)
60	protected {private}
61	{property variables}
62	FPostalCode : string;
63	FCheckNumber : Integer;
64
65
66	{internal variables}
67	pnbcDisplayDims : TStPNBarCodeDims;
68	pnbcDefRes : TStPNBarCodeRes;
69
70	{property methods}
71	function GetVersion : string;
72	procedure SetPostalCode(Value : String);
73	procedure SetVersion (const v : string);
74
75	{internal methods}
76	function DrawTallBar(C : TCanvas;
77	Dims : TStPNBarCodeDims;
78	XPos : Integer;
79	AddSpace : Boolean) : Longint;
80	function DrawShortBar(C : TCanvas;
81	Dims : TStPNBarCodeDims;
82	XPos : Integer;
83	AddSpace : Boolean) : Longint;
84	function DrawNumber(C : TCanvas;
85	Dims : TStPNBarCodeDims;
86	Value : Integer;
87	XPos : Longint;
88	FrontGuard : Boolean;
89	EndGuard : Boolean) : Longint;
90	procedure DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
91	procedure SetCheckNumber;
92
93	(*
94	procedure CMTextChanged(var Msg : TMessage);
95	message CM_TEXTCHANGED;
96	*)
97
98	protected
99	procedure Loaded; override;
100	procedure Paint; override;
101	public
102	constructor Create(AOwner : TComponent); override;
103
104	procedure ComputeSizes(C : TCanvas;
105	Res : TStPNBarCodeRes;
106	var Dims : TStPNBarCodeDims);
107	procedure CopyToClipboard;
108	procedure PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
109	procedure PaintToDC(DC : hDC; Position : TPoint);
110	procedure PaintToPrinterCanvas(ACanvas : TCanvas; Position : TPoint);
111	procedure PaintToPrinterDC(DC : hDC; Position : TPoint);
112	procedure SaveToFile(ACanvas : TCanvas; const FileName : string);
113	procedure SaveToFileRes(Res : TStPNBarCodeRes; const FileName : string);
114
115	published
116	{properties}
117	property Cursor;
118	property Enabled;
119	property Hint;
120	property ParentShowHint;
121	property ShowHint;
122	property Visible;
123
124	property PostalCode : string read FPostalCode write SetPostalCode;
125
126	property Version : string read GetVersion write SetVersion stored False;
127
128	{events}
129	property OnClick;
130	property OnDblClick;
131	property OnMouseDown;
132	property OnMouseMove;
133	property OnMouseUp;
134	end;
135
136
137	implementation
138
139	{* TStPNBarCode *}
140
141	function TStPNBarCode.GetVersion : string;
142	begin
143	Result := StVersionStr;
144	end;
145
146
147	procedure TStPNBarCode.SetVersion(const v : string);
148	begin
149	end;
150
151	constructor TStPNBarCode.Create(AOwner : TComponent);
152	begin
153	inherited Create(AOwner);
154
155	{defaults}
156	pnbcDefRes.XRes := 0;
157	pnbcDefRes.YRes := 0;
158	{set arbitrary values for height/width so that component automatically resizes}
159	Height := 10;
160	Width := 10;
161	PostalCode := '12345';
162	SetCheckNumber;
163	end;
164
165
166	procedure TStPNBarCode.Loaded;
167	begin
168	inherited Loaded;
169	Invalidate;
170	end;
171
172
173	procedure TStPNBarCode.Paint;
174	begin
175	ComputeSizes(Canvas, pnbcDefRes, pnbcDisplayDims);
176	Height := pnbcDisplayDims.Height;
177	Width := pnbcDisplayDims.Width;
178	DrawBarCode(Canvas, pnbcDisplayDims);
179	end;
180
181
182	procedure TStPNBarCode.SetCheckNumber;
183	var
184	I : Longint;
185	begin
186	if (Length(TrimL(FPostalCode)) < 5) then Exit;
187	FCheckNumber := 0;
188	for I := 1 to Length(FPostalCode) do
189	FCheckNumber := FCheckNumber + StrToInt(FPostalCode[I]);
190	I := FCheckNumber mod 10;
191	if (I > 0) then
192	FCheckNumber := 10 - I
193	else
194	FCheckNumber := 0;
195	end;
196
197	procedure TStPNBarCode.SetPostalCode(Value : string);
198	var
199	I : Integer;
200	Local : string;
201	begin
202	if (csLoading in ComponentState) then Exit;
203
204	Local := TrimL(Value);
205
206	{strip non-numerics}
207	I := 1;
208	repeat
209	if not (Local[I] in ['0'..'9']) then
210	System.Delete(Local, I, 1)
211	else
212	Inc(I);
213	until (I > Length(Local));
214
215	{ looks like a valid Postal Code?}
216	if (Local <> FPostalCode) then begin
217	if (Length(Local) in [5, 9, 11]) then begin
218	FPostalCode := Local;
219	SetCheckNumber;
220	Invalidate;
221	end else
222	RaiseStError(EStPNBarCodeError, stscInvalidLength);
223	end; { else it's the same code, don't bother updating }
224	end;
225
226
227	function TStPNBarCode.DrawTallBar(C : TCanvas;
228	Dims : TStPNBarCodeDims;
229	XPos : Integer;
230	AddSpace : Boolean) : Longint;
231	var
232	YPos : Longint;
233	begin
234	Result := XPos;
235	YPos := Dims.Height - 5 - Dims.TallBarHeight;
236	C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.TallBarHeight);
237	Result := Result + Dims.PixPerBar;
238
239	if (AddSpace) then
240	Inc(Result, Dims.PixPerSpace);
241	end;
242
243
244	function TStPNBarCode.DrawShortBar(C : TCanvas;
245	Dims : TStPNBarCodeDims;
246	XPos : Integer;
247	AddSpace : Boolean) : Longint;
248	var
249	YPos : Longint;
250	begin
251	Result := XPos;
252	YPos := Dims.Height - 5 - Dims.ShortBarHeight;
253	C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.ShortBarHeight);
254	Result := Result + Dims.PixPerBar;
255
256	if (AddSpace) then
257	Inc(Result, Dims.PixPerSpace);
258	end;
259
260
261	function TStPNBarCode.DrawNumber(C : TCanvas;
262	Dims : TStPNBarCodeDims;
263	Value : Integer;
264	XPos : Longint;
265	FrontGuard : Boolean;
266	EndGuard : Boolean) : Longint;
267	begin
268	Result := XPos;
269	if (FrontGuard) then
270	Result := DrawTallBar(C, Dims, Result, True);
271
272	case Value of
273	0 : begin
274	Result := DrawTallBar(C, Dims, Result, True);
275	Result := DrawTallBar(C, Dims, Result, True);
276	Result := DrawShortBar(C, Dims, Result, True);
277	Result := DrawShortBar(C, Dims, Result, True);
278	Result := DrawShortBar(C, Dims, Result, True);
279	end;
280
281	1 : begin
282	Result := DrawShortBar(C, Dims, Result, True);
283	Result := DrawShortBar(C, Dims, Result, True);
284	Result := DrawShortBar(C, Dims, Result, True);
285	Result := DrawTallBar(C, Dims, Result, True);
286	Result := DrawTallBar(C, Dims, Result, True);
287	end;
288
289	2 : begin
290	Result := DrawShortBar(C, Dims, Result, True);
291	Result := DrawShortBar(C, Dims, Result, True);
292	Result := DrawTallBar(C, Dims, Result, True);
293	Result := DrawShortBar(C, Dims, Result, True);
294	Result := DrawTallBar(C, Dims, Result, True);
295	end;
296
297	3 : begin
298	Result := DrawShortBar(C, Dims, Result, True);
299	Result := DrawShortBar(C, Dims, Result, True);
300	Result := DrawTallBar(C, Dims, Result, True);
301	Result := DrawTallBar(C, Dims, Result, True);
302	Result := DrawShortBar(C, Dims, Result, True);
303	end;
304
305	4 : begin
306	Result := DrawShortBar(C, Dims, Result, True);
307	Result := DrawTallBar(C, Dims, Result, True);
308	Result := DrawShortBar(C, Dims, Result, True);
309	Result := DrawShortBar(C, Dims, Result, True);
310	Result := DrawTallBar(C, Dims, Result, True);
311	end;
312
313	5 : begin
314	Result := DrawShortBar(C, Dims, Result, True);
315	Result := DrawTallBar(C, Dims, Result, True);
316	Result := DrawShortBar(C, Dims, Result, True);
317	Result := DrawTallBar(C, Dims, Result, True);
318	Result := DrawShortBar(C, Dims, Result, True);
319	end;
320
321	6 : begin
322	Result := DrawShortBar(C, Dims, Result, True);
323	Result := DrawTallBar(C, Dims, Result, True);
324	Result := DrawTallBar(C, Dims, Result, True);
325	Result := DrawShortBar(C, Dims, Result, True);
326	Result := DrawShortBar(C, Dims, Result, True);
327	end;
328
329	7 : begin
330	Result := DrawTallBar(C, Dims, Result, True);
331	Result := DrawShortBar(C, Dims, Result, True);
332	Result := DrawShortBar(C, Dims, Result, True);
333	Result := DrawShortBar(C, Dims, Result, True);
334	Result := DrawTallBar(C, Dims, Result, True);
335	end;
336
337	8 : begin
338	Result := DrawTallBar(C, Dims, Result, True);
339	Result := DrawShortBar(C, Dims, Result, True);
340	Result := DrawShortBar(C, Dims, Result, True);
341	Result := DrawTallBar(C, Dims, Result, True);
342	Result := DrawShortBar(C, Dims, Result, True);
343	end;
344
345	9 : begin
346	Result := DrawTallBar(C, Dims, Result, True);
347	Result := DrawShortBar(C, Dims, Result, True);
348	Result := DrawTallBar(C, Dims, Result, True);
349	Result := DrawShortBar(C, Dims, Result, True);
350	Result := DrawShortBar(C, Dims, Result, True);
351	end;
352	end;
353
354	if (EndGuard) then
355	Result := DrawTallBar(C, Dims, Result, False);
356	end;
357
358
359	procedure TStPNBarCode.ComputeSizes(C : TCanvas;
360	Res : TStPNBarCodeRes;
361	var Dims : TStPNBarCodeDims);
362	var
363	PPIX,
364	PPIY : Longint;
365	begin
366	if csLoading in ComponentState then
367	Exit;
368	{get resolution}
369	if ((Res.XRes > 0) and (Res.YRes > 0)) then begin
370	PPIX := Res.XRes;
371	PPIY := Res.YRes;
372	end else begin
373	PPIX := GetDeviceCaps(C.Handle, LOGPIXELSX);
374	PPIY := GetDeviceCaps(C.Handle, LOGPIXELSY);
375	end;
376
377	{PN bar is 0.015" to 0.025" - use mid value}
378	{add 1 since Canvas.Rectangle draws 1 pixel less than Width}
379	Dims.PixPerBar := Round(PPIX * 0.017) + 1;
380
381	{CenterLine distance is 0.0416" to 0.0500". Space is that minus width of bar}
382	{In all cases the Pitch must be 22 +/-2 bars/Inch where a bar is the bar and}
383	{the trailing space}
384
385	{add 1 since Canvas.Rectangle draws 1 pixel less than Width}
386	Dims.PixPerSpace := Round(0.0475 * PPIX) - Dims.PixPerBar + 1;
387
388	{max height of short bar is 0.050" +/-0.010". To allow for 75dpi, go a}
389	{little less}
390	{add 1 since Canvas.Rectangle draws 1 pixel less than Height}
391	Dims.ShortBarHeight := Round(0.047 * PPIY) + 1;
392
393	{max height of tall bar is 0.125" +/-0.010". To allow for 75dpi, go a}
394	{little less}
395	{add 1 since Canvas.Rectangle draws 1 pixel less than Height}
396	Dims.TallBarHeight := Round(0.122 * PPIY) + 1;
397
398
399	{Total Width of Canvas =
400	FrontGuardBar + Space +
401	(NumberChars + CheckChar) * (5 * (PixelsPerBar + PixelsPerSpace)) +
402	(EndBar w/o Space) +
403	5 pixels left/right margin
404	}
405	Dims.Width :=
406	(Dims.PixPerBar + Dims.PixPerSpace) +
407	(Length(PostalCode) + 1) * (5 * (Dims.PixPerBar + Dims.PixPerSpace)) +
408	Dims.PixPerBar + 10;
409
410	{Height = Height of tall bar + 3 pixel top/bottom margin}
411	Dims.Height := Dims.TallBarHeight + 3;
412	end;
413
414
415	procedure TStPNBarCode.DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
416	var
417	I,
418	XPos : Longint;
419	begin
420	if csLoading in ComponentState then
421	Exit;
422
423	C.Brush.Color := clBlack;
424	C.Brush.Style := bsSolid;
425
426	{Draw the Code}
427	XPos := 5;
428	XPos := DrawNumber(C, Dims, StrToInt(PostalCode[1]), XPos, True, False);
429	for I := 2 to Length(PostalCode) do
430	XPos := DrawNumber(C, Dims, StrToInt(PostalCode[I]), XPos, False, False);
431	DrawNumber(C, Dims, FCheckNumber, XPos, False, True);
432	end;
433
434
435	(*
436	procedure TStPNBarCode.CMTextChanged(var Msg : TMessage);
437	begin
438	SetCheckNumber;
439	Invalidate;
440	end;
441	*)
442
443	procedure TStPNBarCode.CopyToClipboard;
444	var
445	MetaFile : TMetaFile;
446	MetaFileCanvas : TMetaFileCanvas;
447	Bitmap : TBitmap;
448	Dims : TStPNBarCodeDims;
449	begin
450	Clipboard.Clear;
451	Clipboard.Open;
452	try
453	{bitmap}
454	Bitmap := TBitmap.Create;
455	try
456	ComputeSizes(Bitmap.Canvas, pnbcDefRes, Dims);
457	Bitmap.Width := Dims.Width;
458	Bitmap.Height := Dims.Height;
459	DrawBarCode(Bitmap.Canvas, Dims);
460	Clipboard.Assign(Bitmap);
461
462	{metafile}
463	MetaFile := TMetaFile.Create;
464	try
465	MetaFileCanvas := TMetaFileCanvas.Create(MetaFile, 0);
466	try
467	MetaFile.Enhanced := True;
468	MetaFile.Width := ClientWidth;
469	MetaFile.Height := ClientHeight;
470	MetaFileCanvas.Draw(0, 0, Bitmap);
471	finally
472	MetaFileCanvas.Free;
473	end;
474	Clipboard.Assign(MetaFile);
475	finally
476	MetaFile.Free;
477	end;
478
479	finally
480	Bitmap.Free;
481	end
482	finally
483	Clipboard.Close;
484	end;
485	end;
486
487
488
489	procedure TStPNBarCode.PaintToDC(DC : hDC; Position : TPoint);
490	var
491	Bmp : TBitmap;
492	ACanvas : TCanvas;
493	Dims : TStPNBarCodeDims;
494	R1,
495	R2 : TRect;
496	begin
497	ACanvas := TCanvas.Create;
498	ACanvas.Handle := DC;
499	Bmp := TBitmap.Create;
500	try
501	ComputeSizes(ACanvas, pnbcDefRes, Dims);
502	Bmp.Height := Dims.Height;
503	Bmp.Width := Dims.Width;
504	R1 := Rect(0, 0, Dims.Width, Dims.Height);
505	R2 := Rect(Position.X, Position.Y,
506	Dims.Width + Position.X,
507	Dims.Height + Position.Y);
508
509	DrawBarCode(Bmp.Canvas, Dims);
510	ACanvas.CopyRect(R2, Bmp.Canvas, R1);
511	finally
512	Bmp.Free;
513	ACanvas.Free;
514	end;
515	end;
516
517
518
519	procedure TStPNBarCode.PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
520	begin
521	PaintToDC(ACanvas.Handle, Position);
522	end;
523
524
525
526	procedure TStPNBarCode.PaintToPrinterCanvas(ACanvas : TCanvas;
527	Position : TPoint);
528	begin
529	PaintToPrinterDC(ACanvas.Handle, Position);
530	end;
531
532
533
534	procedure TStPNBarCode.PaintToPrinterDC(DC : hDC; Position : TPoint);
535	var
536	Bmp : TBitmap;
537	ACanvas : TCanvas;
538	Dims : TStPNBarCodeDims;
539	R1,
540	R2 : TRect;
541
542	Info : PBitMapInfo;
543	InfoSize : DWORD;
544	ImageSize : DWORD;
545	Image : Pointer;
546	begin
547	ACanvas := TCanvas.Create;
548	Bmp := TBitmap.Create;
549	ACanvas.Handle := DC;
550	try
551	ComputeSizes(ACanvas, pnbcDefRes, Dims);
552	Bmp.Height := Dims.Height;
553	Bmp.Width := Dims.Width;
554	R1 := Rect(0, 0, Dims.Width, Dims.Height);
555	R2 := Rect(Position.X, Position.Y,
556	Dims.Width + Position.X,
557	Dims.Height + Position.Y);
558
559	DrawBarCode(Bmp.Canvas, Dims);
560
561	{Delphi does not allow a simple Canvas.CopyRect to the printer Canvas}
562	with Bmp do begin
563	GetDIBSizes(Handle, InfoSize, ImageSize);
564	GetMem(Info, InfoSize);
565	try
566	GetMem(Image, ImageSize);
567	try
568	GetDIB(Handle, Palette, Info^, Image^);
569	with Info^.bmiHeader do begin
570	StretchDIBits(ACanvas.Handle,
571	R2.Left, R2.Top, Dims.Width, Dims.Height,
572	0, 0, biWidth, biHeight,
573	Image, Info^, DIB_RGB_COLORS, SRCCOPY);
574	end;
575	finally
576	FreeMem(Image, ImageSize)
577	end;
578	finally
579	FreeMem(Info, InfoSize);
580	end;
581	end;
582	finally
583	Bmp.Free;
584	ACanvas.Free;
585	end;
586	end;
587
588
589
590	procedure TStPNBarCode.SaveToFile(ACanvas : TCanvas;
591	const FileName : string);
592	var
593	Bmp : TBitmap;
594	Dims : TStPNBarCodeDims;
595	begin
596	Bmp := TBitmap.Create;
597	try
598	ComputeSizes(ACanvas, pnbcDefRes, Dims);
599	Bmp.Height := Dims.Height;
600	Bmp.Width := Dims.Width;
601	DrawBarCode(Bmp.Canvas, Dims);
602	Bmp.SaveToFile(FileName);
603	finally
604	Bmp.Free;
605	end;
606	end;
607
608
609
610	procedure TStPNBarCode.SaveToFileRes(Res : TStPNBarCodeRes;
611	const FileName : string);
612	var
613	Bmp : TBitmap;
614	Dims : TStPNBarCodeDims;
615	begin
616	Bmp := TBitmap.Create;
617	try
618	ComputeSizes(Bmp.Canvas, Res, Dims);
619	Bmp.Height := Dims.Height;
620	Bmp.Width := Dims.Width;
621	DrawBarCode(Bmp.Canvas, Dims);
622	Bmp.SaveToFile(FileName);
623	finally
624	Bmp.Free;
625	end;
626	end;
627
628	end.