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	torben	2671	// 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.