A VCL Component to print labels

Problem/Question/Abstract:

A simple component to print labels

Answer:

A simple VCL componet to print labels.

A few days ago I wrote an article about a class to print labels (3156)

With the help of Mike Heydon we have rewritten the class to convert it to a component and easier to use.

What do we need to print labels ?

The size (height and width) of every label.
The number of labels per row.
The top and left margin.
The kind of measure: pixels,inches or millimetres.
The font to use.
And of course data to fill the labels.

With the next component we can do it very simply, Im going to use a pseudo-code to explain the use of the component TPrtLabels:

begin
  PrtLabels.Measurements := plmInches; // plmMillimetres or plmPixels
  PrtLabels.Font := FontDialog1.Font; // I get the font from a Font Dialog
  PrtLabels.LabelsPerRow := 4; // 4 Label per row
  PrtLabels.LabelWidth := 3; // only an example
  PrtLabels.LabelHeight := 1.5; // only an example
  PrtLabels.LeftMargin := 0; // only an example
  PrtLabels.TopMargin := 0; // only an example
  PrtLabels.Open; // open the printer
  Table.First // Im going to read a customer table
  while not Table.Eof do
  begin
    PrtLabels.Add(["Name", "Street", "City"]); // I fill the content of every label
    Table.Next;
  end;
  PrtLabels.Close; // close the printer and print any label pending on the buffer
  PrtLabels.Free;
end;

We need only 3 methods: Open, Add and Close.

The properties that we need are:

Measurements(plmInches, plmMillimetres or plmPixels)
LabelsPerRow
LabelWidth
LabelHeight
LeftMargin
TopMargin
Font

The componet:

unit ULabels2;
{
VCL Component to print labels

Authors:
Mike Heydon
Alejandro Castro

Date: 1/Abr/2002
}

interface
uses SysUtils, Windows, Classes, Graphics, Printers;

type
  TPrtLabelMeasures = (plmPixels, plmInches, plmMillimetres);

  TPrtLabels = class(TComponent)
  private
    FFont: TFont;
    FMeasurements: TPrtLabelMeasures;
    FTopMargin,
      FLeftMargin,
      FLabelHeight,
      FLabelWidth: double; // Selected Measure
    FLabelLines,
      FLabelsPerRow: word; // ABS Pixels
    TopMarginPx,
      LeftMarginPx,
      LabelHeightPx,
      LabelWidthPx: integer;
    TabStops: array of word;
    DataArr: array of array of string;
    CurrLab: word;
    procedure SetFont(Value: TFont);
    procedure IniDataArr;
    procedure FlushBuffer;
    procedure SetDataLength(xLabelLines, xLabelsPerRow: Word);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Add(LabLines: array of string);
    procedure Close;
    procedure Open;
  published
    property Font: TFont read FFont write SetFont;
    property Measurements: TPrtLabelMeasures read FMeasurements write FMeasurements;
    property LabelWidth: double read FLabelWidth write FLabelWidth;
    property LabelHeight: double read FLabelHeight write FLabelHeight;
    property TopMargin: double read FTopMargin write FTopMargin;
    property LeftMargin: double read FLeftMargin write FLeftMargin;
    property LabelsPerRow: word read FLabelsPerRow write FLabelsPerRow;
    //    property LabelLines : word read FLabelLines write FLabelLines;
  end;

procedure Register;

implementation

const
  MMCONV = 25.4;

procedure Register;
begin
  RegisterComponents('Mah2001', [TPrtLabels]);
end;

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

  FMeasurements := plmInches;
  FLabelHeight := 0.0;
  FLabelWidth := 0.0;
  FTopMargin := 0.0;
  FLeftMargin := 0.0;
  FLabelsPerRow := 1;
  FLabelLines := 1;
  FFont := TFont.Create;
  TabStops := nil;
  DataArr := nil;
end;

destructor TPrtLabels.Destroy;
begin
  FFont.Free;
  TabStops := nil;
  DataArr := nil;

  inherited Destroy;
end;

procedure TPrtLabels.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TPrtLabels.SetDataLength(xLabelLines, xLabelsPerRow: Word);
begin
  if (xLabelLines + xLabelsPerRow) > 1 then
    SetLength(DataArr, xLabelLines, xLabelsPerRow);
end;

procedure TPrtLabels.Open;
var
  PixPerInX, PixPerInY, i: integer;
begin
  if (FLabelsPerRow + FLabelLines) > 1 then
  begin
    SetLength(TabStops, FLabelsPerRow);
    SetDataLength(FLabelLines, FLabelsPerRow);
    //    SetLength(DataArr,FLabelLines,FLabelsPerRow);
    Printer.Canvas.Font.Assign(FFont);
    Printer.BeginDoc;
    PixPerInX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
    PixPerInY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);

    case FMeasurements of
      plmInches:
        begin
          LabelWidthPx := trunc(LabelWidth * PixPerInX);
          LabelHeightPx := trunc(LabelHeight * PixPerInY);
          TopMarginPx := trunc(TopMargin * PixPerInX);
          LeftMarginPx := trunc(LeftMargin * PixPerInY);
        end;

      plmMillimetres:
        begin
          LabelWidthPx := trunc(LabelWidth * PixPerInX * MMCONV);
          LabelHeightPx := trunc(LabelHeight * PixPerInY * MMCONV);
          TopMarginPx := trunc(TopMargin * PixPerInX * MMCONV);
          LeftMarginPx := trunc(LeftMargin * PixPerInY * MMCONV);
        end;

      plmPixels:
        begin
          LabelWidthPx := trunc(LabelWidth);
          LabelHeightPx := trunc(LabelHeight);
          TopMarginPx := trunc(TopMargin);
          LeftMarginPx := trunc(LeftMargin);
        end;
    end;

    for i := 0 to FLabelsPerRow - 1 do
      TabStops[i] := LeftMarginPx + (LabelWidthPx * i);
    IniDataArr;
  end;
end;

procedure TPrtLabels.Close;
begin
  if (FLabelsPerRow + FLabelLines) > 1 then
  begin
    FlushBuffer;
    Printer.EndDoc;
    TabStops := nil;
    DataArr := nil;
  end;
end;

procedure TPrtLabels.IniDataArr;
var
  i, ii: integer;
begin
  CurrLab := 0;
  for i := 0 to High(DataArr) do // FLabelLines - 1 do
    for ii := 0 to High(DataArr[i]) do //FLabelsPerRow do
      DataArr[i, ii] := '';
end;

procedure TPrtLabels.FlushBuffer;
var
  i, ii, y, SaveY: integer;
begin
  if CurrLab > 0 then
  begin
    if Printer.Canvas.PenPos.Y = 0 then
      Printer.Canvas.MoveTo(0, TopMarginPx);
    y := Printer.Canvas.PenPos.Y;
    SaveY := y;

    for i := 0 to fLabelLines - 1 do
    begin
      for ii := 0 to fLabelsPerRow - 1 do
      begin
        Printer.Canvas.TextOut(TabStops[ii], y, DataArr[i, ii]);
      end;

      inc(y, Printer.Canvas.Textheight('X'));
    end;

    if (LabelHeightPx + SaveY) + LabelHeightPx > Printer.PageHeight then
      Printer.NewPage
    else
      Printer.Canvas.MoveTo(0, LabelHeightPx + SaveY);

    IniDataArr;
  end;
end;

procedure TPrtLabels.Add(LabLines: array of string);
var
  i: integer;
begin

  if Length(LabLines) > FLabelLines then
  begin
    FLabelLines := Length(LabLines);
    SetDataLength(fLabelLines, fLabelsPerRow);
  end;

  inc(CurrLab);

  for i := 0 to high(LabLines) do
    if i <= FLabelLines - 1 then
      DataArr[i, CurrLab - 1] := LabLines[i];

  if CurrLab = FLabelsPerRow then
    FlushBuffer;
end;

end.


Component Download: http://www.baltsoft.com/files/dkb/attachment/ULabels2.zip