unit OCR;
  
interface
  
 uses Windows, SysUtils, Graphics, Classes, PNGImage, GIFImage, JPEG, Math, AsphyreZlib;
  
 type
   TOCRLibSetting = record  //验证码库设置
    SaveBMP: Boolean; //存储转换后的Bmp文件
    BmpPath: String; //Bmp存储路径
    BmpPrefix: String; //Bmp文件前缀
    BmpSuffix: String; //Bmp文件后缀
  end;
  
 type
   //图像大小类
  TOCRSz = record
     W,H: Byte;   //宽，高
  end;
   //特征码模板库类
  TOCRTemplates = record
     Count: Byte;    //数量
    Names: array of String; //名称
    OCRFiles: array of String; //文件名/路径
    OCRSz: array of TOCRSz; //图像大小
    YaoqiuSS: array of Byte;  //是否为算式
  end;
  
//初始化验证码库
function InitOCRLib: Boolean;
//取消使用Dll
procedure CancelUseDLL;
//加载验证码模板库
function LoadOCRLib(const AFileName: String = ''): Boolean;
//图像转换为BMP
function ALL2BMP(const Filename : String; const Bmp: TBitmap): Boolean;
//加载资源dll
function LoadOCRResourceDLL(const ADllName: String): Boolean;
//识别验证码
function RecogOCR(var Success: Boolean; const ImageFile: String): String;
//更改特征码模板
function LoadOCRTemplate(const TmplID: Integer): Boolean;
//加载特征码文件
function LoadOCRFile(const ocrFile: String; const IsAutoSS: Boolean = False): Boolean;
//查找验证码特征文件
function FetchOCR(const StartIndex: Integer; const Width,Height: Integer; const AOCRName: String = ''): Integer;
//验证码库设置
function SetOCRLib(const ASetting: TOCRLibSetting): Boolean;
//获得验证码库设置
function GetOCRLibSetting: TOCRLibSetting;
//获得验证码模板库
function GetOCRTemplates: TOCRTemplates;
//获取最后识别时间(毫秒)
function GetLastRecogTime: DWORD;
//调用AspriseOcr
 //function RecogOCRByOCRLib(const FileName: String): String;
 //释放验证码库/清除特征码文件
function FreeOcr: Boolean;
  
//procedure SetPicFormat(Format: Byte);
 
const
   FMT_AUTO = 4; //自动
  FMT_PNG = 2; //png
  FMT_BMP = 1; //bmp
  FMT_GIF = 3; //gif
  FMT_JPEG = 0; //jpg/jpeg
 
 implementation
  
 uses IniFiles, SSUtils;
  
 type
   RSpeicalEffects = record  //特殊效果
    To1Line: Boolean;   //字符归位
    RemoveZD: Boolean;  //消除噪点
    Y0: Byte;           //Y轴偏移
    XcZD: Byte;         //噪点阀值
  end;
  
 type //字符特征码
  RChar = record
     MyChar: char;          //字符
    used: Boolean;         //已使用
    MyCharInfo: array[0..49, 0..49] of byte;  //字符图像
  end;
  
 type //字符特征文件
  RCharInfo = record
     charwidth: byte; //字符宽度
    charheight: byte; //字符高度
    X0: byte; //第一个字符开始x偏移
    TotalChars: byte; //图象字符总数
    CusDiv : boolean;  //自定义二值化运算
    DivCmp : Byte; //  0:>  1:=  2:<<br>     DivColr : TColor;  //二值化阀值
    _CmpChr,_CmpBg: Boolean;  //比较字符(黑色),比较背景(白色)
    _ClrRect: Boolean;   //清除矩形
    _RectLen: Byte;     //矩形长度
 
     allcharinfo: array[0..42] of RChar; //字符特征码列表
  end;
  
 type
   TOcrVersionSng = array [0..1] of Byte;
   TOcrVersion = record    //版本号
    First,Minjor: Byte;   //版本
    Author: String[10];   //作者
    Name: String[20];     //特征码名称
  end;
  
   ROcrLibFile = record
     Sng: TOcrVersionSng;  //版本标识
    Ver: TOcrVersion;     //版本
    W,H: Byte;            //图像宽,高
    Effect: RSpeicalEffects;  //特殊效果
    CharInfo: RCharInfo;     //特征码
    EffectBLW: Boolean;     //通用二值化
  end;
  
   TOcrLibDllInfo = record
     DllFile: String;
     MDLRPrefix: String;
     MDLRType: String;
   end;
  
 var
   _BITMAP: TBitmap;  //识别图像
  MycharInfo: RCharInfo; //特征码
  _Effect: RSpeicalEffects;  //特效
  _EffBLW: Boolean;  //通用二值化
  SSCode: Byte;   //是否为算式
 
 var
   BmW,BmH: Integer;  //特征码图像宽,高
  OcrName: String;  //特征码名称
  _PicFormat: Byte; //图像格式
  _PicWidth,_PicHeight: Byte; //实际图像宽,高
  Templates: TOCRTemplates; //模板列表
  Setting: TOCRLibSetting;
   LastRecogTime: DWORD;
  
 var
   UseDll: Boolean;
   DllInfo: TOcrLibDllInfo;
  
const
   SP = '@';
  
 procedure CancelUseDLL;
 begin
   UseDll := False;
 end;
  
function GetLastRecogTime: DWORD;
 begin
   Result := LastRecogTime;
 end;
  
function GetOCRLibSetting: TOCRLibSetting;
 begin
   Result := Setting;
 end;
  
function GetOCRTemplates: TOCRTemplates;
 begin
   Result := Templates;
 end;
  
function LoadOCRResourceDLL(const ADllName: String): Boolean;
 var
   strm: TResourceStream;
   hDll: THandle;
   S: String;
   function GetTempPathFileName: String;
   var
     SPath, SFile : PChar;
   begin
     SPath := AllocMem(MAX_PATH);
     SFile := AllocMem(MAX_PATH);
     GetTempPath(MAX_PATH, SPath);
     GetTempFileName(SPath, '~OC', 0, SFile);
     Result := String(SFile);
     FreeMem(SPath, MAX_PATH);
     FreeMem(SFile, MAX_PATH);
     DeleteFile(Result);
   end;
 begin
   Result := False;
   try
     hDll := LoadLibrary(PChar(ADllName));
     if hDll <> 0 then
     begin
       try
         strm := TResourceStream.Create(hDll,
           'SDSOFT_OCR',
           PChar('OCR'));
  
         S := GetTempPathFileName;
         strm.SaveToFile(S);
         try
           UseDll := True;
           Result := LoadOCRLib(S);
         except
           UseDll := False;
         end;
         if Result = False then UseDll := False;
         if UseDll = True then DllInfo.DllFile := ADllName;
  
         DeleteFile(S);
       finally
         FreeLibrary(hDll);
       end;
     end;
     Result := True;
   except
   end;
 end;
  
function SetOCRLib(const ASetting: TOCRLibSetting): Boolean;
 begin
   Result := False;
   try
     Setting := ASetting;
     Result := True;
   except
   end;
 end;
  
function InitOCRLib: Boolean;
 begin
   Result := False;
   try
     UseDll := False;
     DllInfo.DllFile := '';
     DllInfo.MDLRPrefix := '';
     DllInfo.MDLRType := '';
  
     _BITMAP := nil;
     FillChar(MycharInfo,SizeOf(RCharInfo),#0);
     MycharInfo.DivCmp := 3;
     MycharInfo.DivColr := $7FFFFF;
     MycharInfo._CmpChr := True;
     MycharInfo._CmpBg := False;
     MycharInfo.X0 := 0;
     MycharInfo.charwidth := 0;
     MycharInfo.CusDiv := False;
     MycharInfo.charheight := 0;
     FillChar(_Effect,SizeOf(RSpeicalEffects),#0);
     _Effect.To1Line := False;
     _Effect.RemoveZD := False;
     Setting.SaveBMP := False;
     Setting.BmpPrefix := 'OCR';
     Setting.BmpSuffix := '';
     LastRecogTime := 0;
   except
   end;
 end;
  
function FetchOCR(const StartIndex: Integer; const Width,Height: Integer; const AOCRName: String = ''): Integer;
 var
   I: Integer;
 begin
   Result := -1;
   for I := StartIndex to Integer(Templates.Count) - 1 do
   begin
     if (Templates.Names[I] = AOCRName) or
          ((Templates.OCRSz[I].W = Width) and (Templates.OCRSz[I].H = Height))
            then
     begin
       Result := I;
       Break;
     end;
   end;
 end;
  
function LoadOCRLib(const AFileName: String = ''): Boolean;
 var
   Ini: TIniFile;
   S,S2: String;
   I,J: Integer;
  
   FileName: String;
 begin
   Result := False;
   FileName := AFileName;
   if FileName = '' then
     FileName := ExtractFilePath(ParamStr(0))+'OCR.INI';
   try
     Templates.Count := 0;
     SetLength(Templates.Names,0);
     SetLength(Templates.OCRFiles,0);
     Ini := TIniFile.Create(FileName);
     Templates.Count := Byte(Ini.ReadInteger('OCRLIB','TCNT',0));
     SetLength(Templates.Names,Templates.Count*SizeOf(String));
     SetLength(Templates.OCRFiles,Templates.Count*SizeOf(String));
     SetLength(Templates.OCRSz,Templates.Count*SizeOf(TOCRSz));
     SetLength(Templates.YaoqiuSS,Templates.Count*SizeOf(Byte));
     for I := 0 to Templates.Count - 1 do
     begin
       S := Ini.ReadString('OCRLIB','T'+IntToStr(I),'');
       if S <> '' then
       begin
         J := Pos(';',S);
         S2 := Copy(S,1,J-1);
         S := Copy(S,J+1,Length(S)-J+1);
         if UseDll then Templates.OCRFiles[I] := S2
         else Templates.OCRFiles[I] := ExtractFilePath(ParamStr(0))+S2;
         J := Pos(';',S);
         S2 := Copy(S,1,J-1);
         S := Copy(S,J+1,Length(S)-J+1);
         Templates.OCRSz[I].W := Byte(StrToInt(S2));
         J := Pos(';',S);
         S2 := Copy(S,1,J-1);
         S := Copy(S,J+1,Length(S)-J+1);
         Templates.OCRSz[I].H := Byte(StrToInt(S2));
         Templates.YaoqiuSS[I] := Byte(StrToInt(S));
         Templates.Names[I] := Ini.ReadString('OCRNAME','T'+IntToStr(I),'');
       end;
     end;
     if UseDll = True then
     begin
       DllInfo.MDLRPrefix := Ini.ReadString('DLLSETTING','Prefix','');
       DllInfo.MDLRType := Ini.ReadString('DLLSETTING','ResourceType','OCR');
     end;
     Ini.Free;
     Result := True;
   except
   end;
 end;
  
function LoadOCRFile(const ocrFile: String; const IsAutoSS: Boolean = False): Boolean;
 var
   Fstrm: TFileStream;
   strm: TMemoryStream;
   dat: ROcrLibFile;
   function VersVerify: Boolean;
   begin
     Result := (dat.Sng[0] = Byte('O')) and (dat.Sng[1] = Byte('C'));
   end;
 begin
   Result := False;
   try
     Fstrm := TFileStream.Create(ocrFile,fmOpenRead);
     strm := TMemoryStream.Create;
     try
       Fstrm.Position := 0;
       ZDecompressStream(FStrm,strm);
       Fstrm.Free;
  
       strm.Position := 0;
       strm.Read(dat,SizeOf(ROcrLibFile));
       if VersVerify = True then
       begin
         MycharInfo := dat.CharInfo;
         _Effect := dat.Effect;
         BmW := dat.W;
         BmH := dat.H;
         OcrName := dat.Ver.Name;
         _EffBLW := dat.EffectBLW;
         Result := True;
       end;
     finally
       strm.Free;
     end;
     if IsAutoSS = True then SSCode := 1
     else SSCode := 0;
   except
   end;
 end;
 procedure To1Line(const Bmp: TBitmap; Y0,X0,Chw,CharL: Byte);
 type
   xByteArray = array of Byte;
 var
   X,Y: Integer;
   Ch: TBitmap;
   MinJL: xByteArray;
   function MinArr(const Data: xByteArray; const Count: Integer): Byte;
   var
     I: Integer;
   begin
     if Count = 0 then Exit;
     Result := Data[0];
     for I := 0 to Count - 1 do
     begin
       if Data[I] < Result then Result := Data[I];
     end;
   end;
   procedure GetMinJL(const nChar: Byte);
   var
     K,L,M: Byte;
     c: TColor;
     MinJLS: xByteArray;
   begin
     K := X0 + nChar * Chw;
     SetLength(MinJLS,Chw);
     for L := 0 to Chw - 1 do
     begin
       M := 0;
       c := Bmp.Canvas.Pixels[K+L,M+Y0];
       while (c <> clBlack) and (M <= Bmp.Height) do
       begin
         inc(M);
         c := Bmp.Canvas.Pixels[K+L,M+Y0];
       end;
       MinJLS[L] := M;
     end;
     MinJL[nChar] := MinArr(MinJLS,Chw);
     SetLength(MinJLS,0);
   end;
 begin
   SetLength(MinJL,CharL);
   Ch := TBitmap.Create;
   for X := 0 to CharL - 1 do
   begin
     GetMinJL(X);
     Y := X0 + X * Chw;
  
     Ch.Width := Chw;
     Ch.Height := Bmp.Height - MinJL[X];
     Ch.Canvas.Brush.Color := clWhite;
     Ch.Canvas.Brush.Style := bsSolid;
     Ch.Canvas.Pen.Color := clWhite;
     Ch.Canvas.Pen.Style := psSolid;
     Ch.Canvas.Rectangle(0,0,Ch.Width,Ch.Height);
     Ch.Canvas.CopyRect(Rect(0,0,Ch.Width,Ch.Height),Bmp.Canvas,Rect(Y,MinJL[X],Y+Chw,Bmp.Height));
  
     Bmp.Canvas.Brush.Color := clWhite;
     Bmp.Canvas.Brush.Style := bsSolid;
     Bmp.Canvas.Pen.Color := clWhite;
     Bmp.Canvas.Pen.Style := psSolid;
     Bmp.Canvas.Rectangle(Y,MinJL[X],Y+Chw,Bmp.Height);
     Bmp.Canvas.CopyRect(Rect(Y,Y0,Y+Chw,Bmp.Height-MinJL[X]),Ch.Canvas,Rect(0,0,Ch.Width,Ch.Height));
   end;
   Ch.Free;
   SetLength(MinJL,0);
 end;
  
function GetTail(str,sp : String): Integer;
 var
   Temp : String;
 begin
   Temp := Str;
   Delete(Temp,1,Pos(sp,str)+length(sp)-1);
   Result := StrToInt(Temp);
 end;
  
 procedure SlQuickSort(Sl : TStringList; iLo, iHi: Integer);
 var
   Lo, Hi, Mid : Integer;
   T : String;
 begin
   Lo := iLo;
   Hi := iHi;
   Mid := GetTail(Sl[(Lo + Hi) div 2],Sp);
   repeat
     while GetTail(Sl[Lo],Sp) < Mid do Inc(Lo);
     while GetTail(Sl[Hi],Sp) > Mid do Dec(Hi);
     if Lo <= Hi then
     begin
       T := sl[Lo];
       sl[Lo] := sl[Hi];
       sl[Hi] := T;
       Inc(Lo);
       Dec(Hi);
     end;
   until Lo > Hi;
   if Hi > iLo then SlQuickSort(Sl, iLo, Hi);
   if Lo < iHi then SlQuickSort(Sl, Lo, iHi);
 end;
  
 Function HexToInt(Hex :String):Int64;
 Var Sum : Int64;
     I,L : Integer;
 Begin
   L := Length(Hex);
   Sum := 0;
   For I := 1 to L Do
    Begin
    Sum := Sum * 16;
    If ( Ord(Hex[I]) >= Ord('0')) and (Ord(Hex[I]) <= Ord('9')) then
       Sum := Sum + Ord(Hex[I]) - Ord('0')
    else If ( Ord(Hex[I]) >= Ord('A') ) and (Ord(Hex[I]) <= Ord('F')) then
       Sum := Sum + Ord(Hex[I]) - Ord('A') + 10
    else If ( Ord(Hex[I]) >= Ord('a') ) and ( Ord(Hex[I]) <= Ord('f')) then
       Sum := Sum + Ord(Hex[I]) - Ord('a') + 10
    else
       Begin
       Sum := -1;
       break;
       End;
    End;
   Result := Sum;
 End;
  
function GetHead(str,sp : String):string;
 begin
   Result:=copy(str,1,pos(sp,str)-1);
 end;
  
 procedure WhiteBlackImgEx(const bmp: TBitmap);
 type
   xByteArray = array of Byte;
 var
   p: PByteArray;
   J,Y,W: Integer;
   arr: xByteArray;
   function AverageArr(const Data: xByteArray; const Count: Integer): Int64;
   var
     I: Integer;
   begin
     Result := 0;
     if Count = 0 then Exit;
     for I := 0 to Count - 1 do
     begin
       Result := Result + Data[I];
     end;
     Result := Round(Result/Count);
   end;
 begin
   bmp.PixelFormat := pf24bit;
   SetLength(arr,bmp.Height*bmp.Width);
   for Y := 0 to bmp.Height - 1 do
   begin
     p := bmp.ScanLine[Y];
     J := 0;
     while J < bmp.Width*3 do
     begin
       arr[(Y*bmp.Width)+J div 3] := Round((p[J]+p[J+1]+p[J+2])/3);
       Inc(J,3);
     end;
   end;
   W := Byte(AverageArr(Arr,bmp.Height*bmp.Width));
   for Y := 0 to bmp.Height - 1 do
   begin
     p := bmp.ScanLine[Y];
     J := 0;
     while J < bmp.Width*3 do
     begin
       if Round((p[J]+p[J+1]+p[J+2])/3) >= W then
       begin
         p[J] := 0;
         p[J+1] := 0;
         p[J+2] := 0;
       end else
       begin
         p[J] := MaxByte;
         p[J+1] := MaxByte;
         p[J+2] := MaxByte;
       end;
       Inc(J,3);
     end;
   end;
   SetLength(Arr,0);
 end;
  
 procedure Ranse(const bmp: TBitmap; const Color: TColor);
 var
   c: TColor;
   X,Y: Integer;
   r1,g1,b1: Byte;
   r2,g2,b2: Byte;
 begin
   r1 := GetRValue(Color);
   g1 := GetGValue(Color);
   b1 := GetBValue(Color);
   for X := 0 to bmp.Width - 1 do
   begin
     for Y := 0 to bmp.Height - 1 do
     begin
       c := Bmp.Canvas.Pixels[X,Y];
       r2 := GetRValue(c);
       g2 := GetGValue(c);
       b2 := GetBValue(c);
      // if (c <> clWhite) and (c <> clBlack) then
     // begin
        r2 := Round(r1*Min(Abs(r2-MaxByte),MaxByte-r2)/MaxByte);
         g2 := Round(g1*Min(Abs(g2-MaxByte),MaxByte-g2)/MaxByte);
         b2 := Round(b1*Min(Abs(b2-MaxByte),MaxByte-b2)/MaxByte);
         c := RGB(r2,g2,b2);
         Bmp.Canvas.Pixels[X,Y] := c;
     //  end;
    end;
   end;
 end;
  
 procedure Grayscale(const bmp: TBitmap);
 var
   p: PByteArray;
   J,Y,W: Integer;
 begin
   bmp.PixelFormat := pf24bit;
   for Y := 0 to bmp.Height - 1 do
   begin
     p := bmp.ScanLine[Y];
     J := 0;
     while J < bmp.Width*3 do
     begin
       W := (P[J] * 28 + P[J+1] *151 + P[J+2] * 77);
       W := W shr 8;
       P[J] := Byte(W);
       P[J+1] := Byte(W);
       P[J+2] := Byte(W);
       Inc(J,3);
     end;
   end;
   //bmp.PixelFormat := pf1bit;
  //bmp.PixelFormat := pf24bit;
end;
  
function ALL2BMP(const Filename : String; const Bmp: TBitmap): Boolean;
 var
   GIF: TGIFImage;
   jpg: TJPEGImage;
   PNG: TPNGobject;
   FileEx: String;
 begin
   Result := False;
   try
     FileEx := UpperCase(ExtractFileExt(filename));
     if FileEx =  
                       
                    
                    
 
                      




鲜花




握手




雷人




路过




鸡蛋