unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TSimpleOCR =
class
type
TPixCol = Cardinal;
TNode =
class
private
FPixCol: TPixCol;
FChildren:
array of TNode;
FLetter: Char;
public
destructor Destroy;
override;
function Add(PixCol: TPixCol): TNode;
function Child(PixCol: TPixCol): TNode;
end;
private
FRoot: TNode;
FFont: TFont;
protected
procedure InsertLetters(Letters:
string);
function BitmapFromText(
const S:
string): TBitmap;
class function GetPixCol(x: Integer; Bmp: TBitmap): TPixCol;
public
destructor Destroy;
override;
procedure Init(Font: TFont);
overload;
procedure Init(
const Alphabet:
string; Font: TFont);
overload;
function Scan(Bmp: TBitmap):
string;
end;
type
TForm2 =
class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
{ TSimpleOCR }
destructor TSimpleOCR.Destroy;
begin
FreeAndNil(FRoot);
inherited;
end;
procedure TSimpleOCR.Init(
const Alphabet:
string; Font: TFont);
begin
FFont:= Font;
FreeAndNil(FRoot);
FRoot:= TNode.Create;
InsertLetters(Alphabet);
end;
procedure TSimpleOCR.Init(Font: TFont);
var
Alphabet:
string;
ch: Char;
begin
for ch := #32
to #255
do
Alphabet:= Alphabet + ch;
Init(Alphabet, Font);
end;
procedure TSimpleOCR.InsertLetters(Letters:
string);
var
Bmp: TBitmap;
I, X, cx: Integer;
Node: TNode;
begin
Bmp:= BitmapFromText(Letters);
try
X:= 0;
for I := 1
to Length(Letters)
do
begin
Node:= FRoot;
cx:= Bmp.Canvas.TextWidth(Letters[I]);
while cx > 0
do
begin
Node:= Node.Add(GetPixCol(x, bmp));
Inc(X);
Dec(cx);
end;
Node.FLetter:= Letters[I];
end;
finally
Bmp.Free;
end;
end;
function TSimpleOCR.Scan(Bmp: TBitmap):
string;
var
X, Y: Integer;
PixCol: TPixCol;
Node: TNode;
M: Cardinal;
begin
Node:= FRoot;
for X := 0
to Pred(Bmp.Width)
do
begin
Node:= Node.Child(GetPixCol(X, bmp));
if Node <>
nil then
begin
if Node.FChildren =
nil then
begin
Result:= Result + Node.FLetter;
Node:= FRoot;
end;
end else
begin
raise Exception.CreateFmt('
Fehler: OCR kann nach "%s" nicht weiterlesen!', [Result]);
end;
end;
end;
class function TSimpleOCR.GetPixCol(x: Integer; Bmp: TBitmap): TPixCol;
var
y: Integer;
M: Cardinal;
begin
Result:= 0;
M:= 1;
for Y := 0
to Pred(Bmp.Height)
do
begin
if bmp.Canvas.Pixels[x, y] = 0
then
Result:= Result
or M;
M:= M
shl 1;
end;
end;
function TSimpleOCR.BitmapFromText(
const S:
string): TBitmap;
begin
Result:= TBitmap.Create;
Result.Canvas.Font:= FFont;
with Result.Canvas.TextExtent(S)
do
Result.SetSize(cx, cy);
Result.Canvas.TextOut(0, 0, S);
end;
{ TSimpleOCR.TNode }
destructor TSimpleOCR.TNode.Destroy;
var
I: Integer;
begin
for I := High(FChildren)
downto Low(FChildren)
do
FreeAndNil(FChildren[I]);
inherited;
end;
function TSimpleOCR.TNode.Add(PixCol: TPixCol): TNode;
begin
Result:= Child(PixCol);
if Result =
nil then
begin
Result:= TNode.Create;
Result.FPixCol:= PixCol;
Result.FChildren:=
nil;
SetLength(FChildren, Length(FChildren) + 1);
FChildren[High(FChildren)]:= Result;
end;
end;
function TSimpleOCR.TNode.Child(PixCol: TPixCol): TNode;
var
I: Integer;
begin
for I := 0
to High(FChildren)
do
begin
if FChildren[I].FPixCol = PixCol
then
begin
Result:= FChildren[I];
Exit;
end;
end;
Result:=
nil;
end;
{ Form2 }
procedure TForm2.FormCreate(Sender: TObject);
var
OCR: TSimpleOCR;
Bmp: TBitmap;
begin
OCR:= TSimpleOCR.Create;
try
OCR.Init(Canvas.Font);
bmp:= OCR.BitmapFromText('
Hallo das ist ein text der gescannt wird!!');
try
Caption:= OCR.Scan(Bmp);
finally
FreeAndNil(Bmp);
end;
finally
FreeAndNil(OCR);
end;
end;
end.