Sungju's Slow Life

More than 10 years ago, I developed this to use in very small shop. It was almost vanished in my memory, but recently I found it in my old CD. I upload it here for my old memories.

unit BCode39;

interface

uses
  SysUtils, Classes, Controls, Printers, Graphics,
  WinProcs, Dialogs;

type
  TBCode39 = class(TComponent)
  private
    { Private declarations }
    pixPerMiliX, pixPerMiliY : Real; // ?–?Æ?Ã?Õ¥Á «»ºøºˆ
    FBarWidth : integer;
    FBarHeight : integer;
    FBarData : String;
    FBarCharPrint : Boolean;
    FBarColor : TColor;
    PChars : array[1..44] of String;
    procedure defCode39;
    procedure setBarData(value : String);
  protected
    { Protected declarations }
    function pixToMiliX : Real;
    function pixToMiliY : Real;
    function miliToPixX : Real;
    function miliToPixY : Real;
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    procedure printBarCode(xPos, yPos : integer);
  published
    { Published declarations }
    property BarWidth : integer read FBarWidth write FBarWidth default 100; // 10 ºæ?º?Ã?Õ
    property BarHeight : integer read FBarHeight write FBarHeight default 50; // 5ºæ?º?Ã?Õ
    property Data : string read FBarData write setBarData;
    property BarCharPrint : boolean read FBarCharPrint write FBarCharPrint default TRUE;
    property BarColor : TColor read FBarColor write FBarColor default clBlack;
  end;

procedure Register;

implementation

const
    chars = '1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ-. *$/+%';

    NS = chr(0);             { æ„¿? ?¯?È }
    WS = chr(0) + chr(0);    { ±?¿? ?¯?È }
    NB = chr(255);           { æ„¿? ??¥Î }
    WB = chr(255) + chr(255);{ ±?¿? ??¥Î }


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

    defCode39;

    pixPerMiliX := miliToPixX;
    pixPerMiliY := miliToPixY;
    FBarWidth := 100;
    FBarHeight := 50;
    FBarCharPrint := True;
    FBarColor := clBlack;
end;

procedure TBCode39.defCode39;
begin
    PChars[01] := WB + NS + NB + WS + NB + NS + NB + NS + WB;  { "1" }
    PChars[02] := NB + NS + WB + WS + NB + NS + NB + NS + WB;  { "2" }
    PChars[03] := WB + NS + WB + WS + NB + NS + NB + NS + NB;  { "3" }
    PChars[04] := NB + NS + NB + WS + WB + NS + NB + NS + WB;  { "4" }
    PChars[05] := WB + NS + NB + WS + WB + NS + NB + NS + NB;  { "5" }
    PChars[06] := NB + NS + WB + WS + WB + NS + NB + NS + NB;  { "6" }
    PChars[07] := NB + NS + NB + WS + NB + NS + WB + NS + WB;  { "7" }
    PChars[08] := WB + NS + NB + WS + NB + NS + WB + NS + NB;  { "8" }
    PChars[09] := NB + NS + WB + WS + NB + NS + WB + NS + NB;  { "9" }
    PChars[10] := NB + NS + NB + WS + WB + NS + WB + NS + NB;  { "10" }
    PChars[11] := WB + NS + NB + NS + NB + WS + NB + NS + WB;  { "A" }
    PChars[12] := NB + NS + WB + NS + NB + WS + NB + NS + WB;  { "B" }
    PChars[13] := WB + NS + WB + NS + NB + WS + NB + NS + NB;  { "C" }
    PChars[14] := NB + NS + NB + NS + WB + WS + NB + NS + WB;  { "D" }
    PChars[15] := wb + ns + nb + ns + wb + ws + nb + ns + nb;  { "e" }
    PChars[16] := nb + ns + wb + ns + wb + ws + nb + ns + nb;  { "f" }
    PChars[17] := nb + ns + nb + ns + nb + ws + wb + ns + wb;  { "g" }
    PChars[18] := wb + ns + nb + ns + nb + ws + wb + ns + nb;  { "h" }
    PChars[19] := nb + ns + wb + ns + nb + ws + wb + ns + nb;  { "i" }
    PChars[20] := nb + ns + nb + ns + wb + ws + wb + ns + nb;  { "j" }
    PChars[21] := wb + ns + nb + ns + nb + ns + nb + ws + wb;  { "k" }
    PChars[22] := nb + ns + wb + ns + nb + ns + nb + ws + wb;  { "l" }
    PChars[23] := wb + ns + wb + ns + nb + ns + nb + ws + nb;  { "m" }
    PChars[24] := nb + ns + nb + ns + wb + ns + nb + ws + wb;  { "n" }
    PChars[25] := wb + ns + nb + ns + wb + ns + nb + ws + nb;  { "o" }
    PChars[26] := nb + ns + wb + ns + wb + ns + nb + ws + nb;  { "p" }
    PChars[27] := nb + ns + nb + ns + nb + ns + wb + ws + wb;  { "q" }
    PChars[28] := wb + ns + nb + ns + nb + ns + wb + ws + nb;  { "r" }
    PChars[29] := nb + ns + wb + ns + nb + ns + wb + ws + nb;  { "s" }
    PChars[30] := nb + ns + nb + ns + wb + ns + wb + ws + nb;  { "t" }
    PChars[31] := wb + ws + nb + ns + nb + ns + nb + ns + wb;  { "u" }
    PChars[32] := nb + ws + wb + ns + nb + ns + nb + ns + wb;  { "v" }
    PChars[33] := wb + ws + wb + ns + nb + ns + nb + ns + nb;  { "w" }
    PChars[34] := nb + ws + nb + ns + wb + ns + nb + ns + wb;  { "x" }
    PChars[35] := wb + ws + nb + ns + wb + ns + nb + ns + nb;  { "y" }
    PChars[36] := nb + ws + wb + ns + wb + ns + nb + ns + nb;  { "z" }
    PChars[37] := nb + ws + nb + ns + nb + ns + wb + ns + wb;  { "-" }
    PChars[38] := wb + ws + nb + ns + nb + ns + wb + ns + nb;  { "." }
    PChars[39] := nb + ws + wb + ns + nb + ns + wb + ns + nb;  { " " }
    PChars[40] := nb + ws + nb + ns + wb + ns + wb + ns + nb;  { "*" }
    PChars[41] := nb + ws + nb + ws + nb + ws + nb + ns + nb;  { "$" }
    PChars[42] := nb + ws + nb + ws + nb + ns + nb + ws + nb;  { "/" }
    PChars[43] := nb + ws + nb + ns + nb + ws + nb + ws + nb;  { "+" }
    PChars[44] := nb + ns + nb + ws + nb + ws + nb + ws + nb;  { "%" }
end; { of defCode39 }

// 1 Pixel?™¿ª ?–?Æ?Ã?Õ?™¿??Œ ?Ÿ?ŸæÓ¡‹.
function TBCode39.pixToMiliX : Real;
begin
    pixToMiliX := 1 / (GetDeviceCaps(Printer.Handle, LOGPIXELSX) / 25.3995);
end;

function TBCode39.pixToMiliY : Real;
begin
    pixToMiliY := 1 / (GetDeviceCaps(Printer.Handle, LOGPIXELSY) / 25.3995);
end;

// 1?–?Æ?Ã?Õ?™¿ª Pixel?™¿??Œ ?Ÿ?ŸæÓ¡‹.
function TBCode39.miliToPixX : Real;
begin
    miliToPixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / 25.3995;
end;

function TBCode39.miliToPixY : Real;
begin
    miliToPixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY) / 25.3995;
end;

procedure TBCode39.setBarData(value : String);
begin
    FBarData := UpperCase(value);
end;

procedure TBCode39.printBarCode(xPos, yPos : Integer);
var
    l, count, i, j : Integer;
    letter, code, tempData : String;
    tempPenColor, tempFontColor : TColor;

    oneLinePixelX, oneLinePixelY : Integer;
    FontHeight : Integer;
begin
    // ?‚?¬¿Ã ??¿€µ«¥¬ ¡¬«•?¶ ¿ß«— ?˪Í
    xPos := Trunc(xPos * pixPerMiliX);
    yPos := Trunc(yPos * pixPerMiliY);

    tempData := '*' + FBarData + '*';

    // «— ?Û¿Œ¥Á ?–?Æ?Ã?Õºˆ = ?Ÿƒ?µÂ ?–¿Ã / (?—?Ÿƒ?µÂ ?Æ¿?ºˆ * «— ?Æ¿?ºˆ¿« ?Û¿Œºˆ)
    // «— ?Æ¿?¥Á ?Û¿Œºˆ = 12 + ?¯?È «œ?™ = 13
    // «— line¥Á pixelºˆ = «— ?Û¿Œ¥Á ?–?Æ?Ã?Õºˆ * ?–?Æ?Ã?Õ¥Á «»ºøºˆ
    oneLinePixelX := Trunc((FBarWidth / (Length(tempData) * 13) * pixPerMiliX));

    // ?Ÿƒ?µÂ ?Ù¿Ãø° ¥Î«— «»ºøºˆ = ?Ÿƒ?µÂ ?Ù¿Ã * ?–?Æ?Ã?Õ¥Á «»ºøºˆ
    oneLinePixelY := Trunc(FBarHeight * pixPerMiliY);
    // ??æ‡ ?Ÿƒ?µÂ ?Æ¿? ?‚?¬??ø°¥¬ ±? ±Ê¿Ã???? ?Ÿƒ?µÂ ±Ê¿Ãø°º? ª´¥Ÿ.
    if FBarCharPrint then begin
        FontHeight := Printer.Canvas.Font.Height;
        if FontHeight < 0 then
            FontHeight := -FontHeight;
        oneLinePixelY := oneLinePixelY - FontHeight - 3;
    end;

    count := 0;  // ø?¬  ??¿€¡°

    tempPenColor := Printer.Canvas.Pen.Color;
    tempFontColor := Printer.Canvas.Font.Color;
    with Printer do begin
        Canvas.Pen.Color := FBarColor;
        Canvas.Font.Color := FBarColor;
    end;



    for l := 1 to Length(tempData) do begin
        letter := copy(tempData, l, 1);
        if pos(letter, chars) < 0 then begin
            raise Exception.Create('Illegal Bar Code Data');
        end;
        code := PChars[pos(letter, chars)] + NS;
        for i := 1 to Length(code) do begin
            for j := 1 to oneLinePixelX do begin
                if code[i]  #0 then begin
                    Printer.Canvas.MoveTo(xPos + count, yPos);
                    Printer.Canvas.LineTo(xPos + count, yPos + oneLinePixelY);
                end;
                count := count + 1;
            end;
        end;
    end;

    if FBarCharPrint then begin
        Printer.Canvas.TextOut(xPos + oneLinePixelX,
                               yPos + oneLinePixelY + 3, FBarData);
    end;

    Printer.Canvas.Pen.Color := tempPenColor;
    Printer.Canvas.Font.Color := tempFontColor;
end;

procedure Register;
begin
  RegisterComponents('LITH', [TBCode39]);
end;

end.

Following one is for print purpose.

unit BC39Prn;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  BCode39, Printers;

type
  TBCodePrint = class(TBCode39)
  private
    { Private declarations }
    TColCount : Integer;
    TRowCount : Integer;
    TChkEtcPrn : Boolean;
    TEtcData1 : String;
    TEtcData2 : String;
    TStartCount : Integer;
    TpUpperMargin : Integer;
    TpLeftMargin : Integer;
    TbUpperMargin : Integer;
    TbLeftMargin : Integer;

    miliPerPixX, miliPerPixY : Real;  // «»ºø¥Á ?–?Æ?Ã?Õºˆ
    pixPerMiliX, pixPerMiliY : Real;  // ?–?Æ?Ã?Õ¥Á «»ºøºˆ
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    procedure printBar;
  published
    { Published declarations }
    property ColumCount : Integer read TColCount write TColCount default 4;
    property RowCount : Integer read TRowCount write TRowCount default 8;
    property etcPrnCheck : Boolean read TChkEtcPrn write TChkEtcPrn default FALSE;
    property EtcData1 : String read TEtcData1 write TEtcData1;
    property EtcData2 : String read TEtcData2 write TEtcData2;
    property StartCount : Integer read TStartCount write TStartCount default 0;
    property pUpperMargin : Integer read TpUpperMargin write TpUpperMargin default 0;
    property pLeftMargin : Integer read TpLeftMargin write TpLeftMargin default 0;
    property bUpperMargin : Integer read TbUpperMargin write TbUpperMargin default 0;
    property bLeftMargin : Integer read TbLeftMargin write TbLeftMargin default 0;
  end;

procedure Register;

implementation

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

    ColumCount := 4;
    RowCount := 8;
    etcPrnCheck := False;
    EtcData1 := '';
    EtcData2 := '';
    StartCount := 0;
    pUpperMargin := 0;
    pLeftMargin := 0;
    bUpperMargin := 0;
    bLeftMargin := 0;

    miliPerPixX := pixToMiliX;
    miliPerPixY := pixToMiliY;
    pixPerMiliX := miliToPixX;
    pixPerMiliY := miliToPixY;
end;

procedure TBCodePrint.printBar;
var
    xPos, yPos : Integer;
    oneBarLength, chrHeight : Integer;
    FontHeight : Integer;
    OrgFontHeight : Integer;
begin
    if Printer.Aborted then
        exit;
    if StartCount >= (ColumCount * RowCount) then begin
        Printer.NewPage;
        StartCount := 0;
    end;

    Printer.Canvas.TextOut(1, 1, ' ');

//    oneBarLength := BarWidth + 6;
    oneBarLength := BarWidth + bLeftMargin;
    xPos := startCount mod columCount;
    xPos := pLeftMargin + (xPos * oneBarLength);

    yPos := startCount div columCount;

    chrHeight := 0;
    FontHeight := Printer.Canvas.Font.Height;
    OrgFontHeight := FontHeight;
    if FontHeight < 0 then
        FontHeight := -FontHeight;

    FontHeight := FontHeight + 4;

    if etcPrnCheck then { ±‚?? ¡§?? ?‚?¬ ±Ê¿Ã on Pixel }
        chrHeight := Trunc((FontHeight * 2) * miliPerPixY);

    yPos := pUpperMargin + (yPos * (BarHeight + chrHeight + bUpperMargin));

    PrintBarCode(xPos, yPos);
    if etcPrnCheck then begin
        yPos := yPos + BarHeight;
        Printer.Canvas.TextOut(Trunc(xPos * pixPerMiliX),
                               Trunc(yPos * pixPerMiliY),
                               etcData1);
        Printer.Canvas.Font.Height := FontHeight + (FontHeight Div 2);
        yPos := yPos + Trunc(FontHeight * miliPerPixY);
        Printer.Canvas.TextOut(Trunc(xPos * pixPerMiliX),
                               Trunc(yPos * pixPerMiliY),
                               etcData2);
        Printer.Canvas.Font.Height := OrgFontHeight;
    end;
    startCount := startCount + 1;
end;

procedure Register;
begin
  RegisterComponents('LITH', [TBCodePrint]);
end;

end.