画像認識 (ID：31275)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

もう十分遅い気がしますが、適当に作ったのでお披露目します。

image1 サイズ 370x330
image2 サイズ 30x38
image3 サイズ 370x57
image4 サイズ 370x57

button1 caption: 画像ペースト
button2 caption: 配列作成
button3 caption: 認識

memo1

を置いて（各イベントはアタッチ）、下記ユニットコピペで。
使い方は、「配列作成」ボタンをクリックしテンプレート配列を作成後、
image1で数値を２回りくらい大きめにマウスでドラッグし、「認識」ボタンクリック。
たたき台としてはまあまあの認識率です。きちんと文字の多きさを合わせれば99%以上は出るでしょう。
ほとんどのコードがWEBからのコピペでできています。いい時代だなぁ。
----------------------------------------
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Clipbrd, StdCtrls, ExtCtrls, math;

type
  TRGBTripleArray = array[0..High(Integer) div 3 - 1] of RGBTRIPLE;
  PRGBTripleArray = ^TRGBTripleArray; //配列型のポインタ

TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Memo1: TMemo;
    Button2: TButton;
    Image2: TImage;
    Button3: TButton;
    Image3: TImage;
    Image4: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

FDrag: boolean; //マウスがドラッグ中かを示すフラグ
  DownPt: TPoint; //描く矩形の基点となるマウスがおろされた座標
  RR: TRect; //現在の選択矩形

MatchSt: array[0..9] of array[0..31] of array[0..23] of Integer;

implementation

{$R *.dfm}

procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer; size: Integer);
var
  LogFont: TLogFont;
  SaveFont: TFont;
begin

SaveFont := TFont.Create;
  SaveFont.Assign(CV.Font);

GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);

with LogFont do
  begin

lfEscapement := angle * 10; //角度は0.1度単位

lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;

lfQuality := ANTIALIASED_QUALITY; //最高画質
    lfHeight := size; //負
    lfWidth := 0; //ゼロ
    lfWeight := FW_EXTRABOLD; //太さ

{ Font Weights }
       {
        FW_DONTCARE = 0;         FW_EXTRABOLD = 800;
        FW_THIN = 100;           FW_HEAVY = 900;
        FW_EXTRALIGHT = 200;     FW_ULTRALIGHT = FW_EXTRALIGHT;
        FW_LIGHT = 300;          FW_REGULAR = FW_NORMAL;
        FW_NORMAL = 400;         FW_DEMIBOLD = FW_SEMIBOLD;
        FW_MEDIUM = 500;         FW_ULTRABOLD = FW_EXTRABOLD;
        FW_SEMIBOLD = 600;       FW_BLACK = FW_HEAVY;
        FW_BOLD = 700;
      }

end;

CV.Font.Handle := CreateFontIndirect(LogFont);
  SetBkMode(CV.Handle, TRANSPARENT);

CV.TextOut(x, y, sText);

CV.Font.Assign(SaveFont);
  SaveFont.Free;
end;

procedure BrendImage(imageA: TImage; imageB: TImage; rate: Integer);
var
  n, m: Integer;
  PA, PB: PRGBTripleArray;

r, g, b: Integer;

begin

for n := 0 to imageA.Picture.bitmap.height - 1 do
  begin
    PA := imageA.Picture.bitmap.ScanLine[n];
    PB := imageB.Picture.bitmap.ScanLine[n];
    for m := 0 to imageA.Picture.bitmap.width - 1 do
    begin
      r := PA[m].rgbtRed;
      g := PA[m].rgbtGreen;
      b := PA[m].rgbtBlue;

PB[m].rgbtRed := (r * rate + PB[m].rgbtRed * (100 - rate)) div 100;
      PB[m].rgbtGreen := (r * rate + PB[m].rgbtGreen * (100 - rate)) div 100;
      PB[m].rgbtBlue := (r * rate + PB[m].rgbtBlue * (100 - rate)) div 100;

end;
  end;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin

if Clipboard.HasFormat(CF_BITMAP) then
  begin
    Image1.Picture.Assign(Clipboard);
  end;

end;

procedure TForm1.Button2Click(Sender: TObject);
var
  gb: TBitmap;

I, J, K, r, g, b, kido, posx, posy: Integer;
  PA, PB: PRGBTripleArray;
  sub, minsub, minnum: Integer;
  min_by_num: array[0..9] of Integer;

begin

gb := TBitmap.Create;
  gb.Width := Image2.Width;
  gb.Height := Image2.Height;

//前の矩形を消去
  Image1.Canvas.DrawFocusRect(RR);

gb.Canvas.CopyRect(Rect(0, 0, Image2.Width, Image2.Height),

Image1.Canvas,

RR
    );

Image2.Picture.Bitmap.Assign(gb);

Image2.Picture.Bitmap.PixelFormat := pf24bit;

gb.Free;

//新たな座標で矩形を描く
  Image1.Canvas.DrawFocusRect(RR);

Application.ProcessMessages;

minsub := High(Integer);
  minnum := -1;

//マッチング処理開始

for K := 0 to 9 do   //10種類（0〜9）を順番に試す
  begin
     ;

min_by_num[K] := High(Integer);

for posy := 0 to 5 do     //座標を縦横1dotにずらしながら
    begin
      for posx := 0 to 5 do
      begin

sub := 0;
        for I := 0 to 31 do    //24x32の矩形領域で比較
        begin

PA := image2.Picture.bitmap.ScanLine[I + posy];

for J := 0 to 23 do
          begin
            r := PA[J + posx].rgbtRed;
            g := PA[J + posx].rgbtGreen;
            b := PA[J + posx].rgbtBlue;

kido := 256 - ((r + g + b) div 3);

if kido <= 0 then
              kido := 0;

if kido >= 256 then
              kido := 255;

kido := kido div 16;

sub := sub + abs(MatchSt[K][I][J] - kido);//差分絶対値和を積算している

end;

//算出した輝度の差分絶対値和が今までのものより小さいなら、その時点でのベストを更新
        if sub < minsub then
        begin
          minsub := sub;
          minnum := K;
        end;

if sub < min_by_num[K] then  //数字毎のベストの集計
        begin
          min_by_num[K] := sub;
        end;

end;
    end;

Memo1.Lines.Add( Format( '%d:最小値=%d', [K,min_by_num[K]] ) );

end;

Memo1.Lines.Add('--------');
  Memo1.Lines.Add( Format( '認識値:%d', [minnum] ) );

end;

procedure TForm1.Button3Click(Sender: TObject);
var

FontName: array[0..8] of AnsiString;
  I, J, K, fsize: Integer;
  ypos: Integer;

PA, PB: PRGBTripleArray;

r, g, b: Integer;
  St: AnsiString;
  kido: Integer;

begin

FontName[0] := 'Times New Roman';
  FontName[1] := 'Lucida Console';
  FontName[2] := 'ＭＳ Ｐゴシック';
  FontName[3] := 'ＭＳ 明朝';
  FontName[4] := 'MS UI Gothic';
  FontName[5] := 'Tahoma';
  FontName[6] := 'Verdana';
  FontName[7] := 'Courier New';
  FontName[8] := 'Arial';

image3.Picture.Bitmap.PixelFormat := pf24bit;
  image4.Picture.Bitmap.PixelFormat := pf24bit;

image3.Picture.bitmap.Width := image3.Width;
  image4.Picture.bitmap.Width := image4.Width;

image3.Picture.bitmap.height := image3.height;
  image4.Picture.bitmap.height := image4.height;

for I := 0 to 8 do
  begin

fsize := -32;
    ypos := 0;

if I = 1 then
      ypos := 2;

if I = 5 then       //フォント毎に微調整しないとうまくない
      fsize := -31
    else if I = 1 then
      fsize := -30
    else if I = 6 then
      fsize := -30
    else if I = 7 then
      fsize := -35
    else if I = 8 then
      fsize := -33;

image3.Canvas.Font.Name := FontName[i];
    image1.Canvas.Font.Name := FontName[i];

image3.Canvas.Brush.Color := clWhite;
    image3.Canvas.FillRect(Rect(0, 0, image3.Width, image3.height));

for J := 0 to 9 do
    begin
      AngleTextOut(image3.canvas, IntToStr(J), 10 + 34 * J, 8 + ypos, 0, fsize);

AngleTextOut(image1.canvas, IntToStr(J), 10 + 34 * J, 8 + 34 * I + ypos, 0, fsize);

end;

BrendImage(image3, image4, 100 div (I + 1));

end;

// 配列の生成。輝度はRGBの平均で代用。
  // また、0〜15に正規化している。
  for K := 0 to 9 do
  begin
      //Memo1.Lines.Add( IntToStr(K) + '--------------');

for I := 0 to 31 do
    begin

PA := image4.Picture.bitmap.ScanLine[I + 10]; 
         //St :='';

for J := 0 to 23 do
      begin
        r := PA[K * 34 + J + 8].rgbtRed;
        g := PA[K * 34 + J + 8].rgbtGreen;
        b := PA[K * 34 + J + 8].rgbtBlue;

kido := 256 - ((r + g + b) div 3);

if kido <= 0 then
          kido := 0;

if kido >= 256 then
          kido := 255;

kido := kido div 16;

MatchSt[K][I][J] := kido;

//St := St+ ',' + Format( '%x', [kido] );
      end;
        //Memo1.Lines.Add( St);

end;

procedure TForm1.FormShow(Sender: TObject);
begin
  if Clipboard.HasFormat(CF_BITMAP) then
  begin
    Image1.Picture.Assign(Clipboard);
  end;

end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbRight then Exit;
   //前の矩形を消去
  Image1.Canvas.DrawFocusRect(RR);
  DownPt := Point(X, Y);
  FDrag := true;
  RR := Rect(X, Y, X, Y);
  Image1.Canvas.DrawFocusRect(RR);
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if FDrag then begin
   //前の矩形を消去
    Image1.Canvas.DrawFocusRect(RR);

//現在のマウス位置と基点の座標から新たな矩形をセット
    RR := Rect(MIN(Downpt.X, X), MIN(Downpt.Y, Y),
      MAX(Downpt.X, X), MAX(Downpt.Y, Y));
   //新たな座標で矩形を描く
    Image1.Canvas.DrawFocusRect(RR);

end;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  //ドラッグ終了でフラグを Falseに
  FDrag := false;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る