MainForm.pas ( File view )

  • By adm.maniaco 2014-09-01
  • View(s):170
  • Download(s):11
  • Point(s): 2
			unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, StdCtrls, ComCtrls, ToolWin, Jpeg, ImgList, ExtCtrls,
  CameraForm, SettingsForm, EnrollmentForm, AboutForm, NCore, NUtils,
  NLicensing, NMatchers,
  NExtractors, NImages, NTemplates, NDeviceManager, Database, Math;

const
  WM_PRINT_MESSAGE = WM_APP + 1987;

type
  TJob = (jEnrolling = 0, jEnrollingWithGeneralization = 1, jMatching = 2,
    jWorking = 3, jEmpty);

  TMainForm = class(TForm)
    tbLog: TRichEdit;
    MainMenu: TMainMenu;
    menuItemTools: TMenuItem;
    menuItemClearLog: TMenuItem;
    menuItemSource: TMenuItem;
    menuItemExit: TMenuItem;
    CameraTimer: TTimer;
    pnlCenter: TPanel;
    SplitterBottom: TSplitter;
    menuItemFaceDetection: TMenuItem;
    menuItemClearDatabase: TMenuItem;
    menuItemFile: TMenuItem;
    menuItemDevice: TMenuItem;
    menuItemSettings: TMenuItem;
    OpenDialog: TOpenDialog;
    menuItemJobs: TMenuItem;
    menuItemEnroll: TMenuItem;
    menuItemEnrollWithGeneralization: TMenuItem;
    menuItemMatch: TMenuItem;
    menuItemHelp: TMenuItem;
    menuItemAbout: TMenuItem;
    ToolBar: TToolBar;
    btnEnroll: TToolButton;
    btnMatch: TToolButton;
    pnlBottom: TPanel;
    lvMatchResults: TListView;
    SplitterBottomPanel: TSplitter;
    ImageList: TImageList;
    pnlLog: TPanel;
    lblLog: TLabel;
    pnlMatchResults: TPanel;
    lblMatchResults: TLabel;
    imgLeft: TImage;

    procedure menuItemClearLogClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CameraTimerTimer(Sender: TObject);
    procedure menuItemFaceDetectionClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure menuItemClearDatabaseClick(Sender: TObject);
    procedure menuItemDeviceClick(Sender: TObject);
    procedure menuItemExitClick(Sender: TObject);
    procedure menuItemSettingsClick(Sender: TObject);
    procedure btnEnrollmentClick(Sender: TObject);
    procedure menuItemFileClick(Sender: TObject);
    procedure menuItemAboutClick(Sender: TObject);
    procedure btnMatchingClick(Sender: TObject);
    procedure menuItemEnrollWithGeneralizationClick(Sender: TObject);

  private
    FActiveDeviceIndex: Integer;

    FJob: TJob; // Enrolling/Matching/None
    FApplicationExit: Boolean;
    // For camera
    // Extracting
    FEnrollStreamIndex: Integer;
    FEnrollTemplateSize: TNleTemplateSize;
    FCurrentMatchingAttempt: Integer;

    // Generalizing
    FGeneralizationTemplateCount: Integer;
    FGeneralizationTemplates: TArrayOfTNLTemplate;

    // Shared
    FImageToSaveWhileEnroll: TNImage;

    // Settings
    FFileNameAsID: Boolean;
    FFlipImageHorizontally: Boolean;
    FFlipImageVertically: Boolean;
    FTemplateCountForGeneralization: Integer;
    FSaveImages: Boolean;
    FMatchingAttempts: Integer;
    FIdentifyTemplateSize: TNleTemplateSize;
    FMatchingStreamLength: Integer;
    FEnrollStreamLength: Integer;
    FBackUppedMaxRecords: Integer;

    Licenses: TArrayOfStrings;
    LicensesBss: TArrayOfStrings;

    // Functions
    // Settings initialization
    procedure InitSettings();
    function GetThumbnail(image: TNImage; face: TNleFace): TNImage;
    // Misc functions
    // Prints message if generalization was failed
    procedure GeneralizationFailedMessage;
    // Gets selected image format from open dialog
    function GetImageFormatFromOpenDialog: TNImageFormat;
    procedure AssignFilterToOpenDialog;
    // Extracts file name from the given path (without extension)
    function ExtrFileName(src: String): String;
    // Shows form asking for EnrollmentID
    procedure AskForEnrollmentID(var enrollmentID: String);
    // Extracts template while enrolling image from camera
    function ExtractFaceFeatures(grayImage: TNImage; rgbImage: TNImage;
      var template: TNLTemplate; EnrollStream: Integer;
      detectionDetails: TNleDetectionDetails): Boolean;
    // Enrolls image to DB and saves it to hard disk if 'Save images' option is checked
    function EnrollImage(template: TNLTemplate; face: TNleFace): Boolean;
    procedure SaveToDB(imageID: string; var features: TNLTemplate;
      image: TNImage; face: TNleFace);
    // Recieves MatchingResult array and prints it to output control
    procedure OnMatchingResultMessage(var Msg: TMessage);
      message WM_PRINT_MESSAGE;

    // GUI paint events
    procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure DrawEyes(var pic: TBitmap; var Eyes: TNleEyes;
      imageFromCamera: Boolean = false);
    procedure DrawMultiFaces(var pic: TBitmap; var faces: TArrayOfTNleFace;
      facesCount: Integer; imageFromCamera: Boolean = false);

    // Assigns image to TBitmap
    procedure PaintImageToTBitmap(image: TNImage; destination: TBitmap);
    // Draws TBitmap on TImage
    procedure PaintBitmapToTImage(image: TNImage; src: TBitmap;
      destination: TImage);
    // Functions verifies image and paints it (checks whether there are faces on image)
    function VerifyAndPaintImage(image: TNImage; rgbImage: TNImage): Boolean;
    // Used to paint image recieved from camera
    procedure PaintCameraImage(image: TNImage; rgbImage: TNImage);

    // Timer calls this function:
    procedure CapturedImage(var grayImage: TNImage; var rgbImage: TNImage);

    // Enrollment and matching
    // 1. Enroll from file
    procedure EnrollFromFile;
    // 2. Match from file
    procedure MatchFromFile;
    // 3. Eroll with generalization from file
    procedure GeneralizeFromFile;

    // 1. Enroll from camera
    procedure EnrollFromCamera(grayImage: TNImage; rgbImage: TNImage);
    // 2. Match from camera
    procedure MatchFromCamera(grayImage: TNImage; rgbImage: TNImage);
    // 3. Enroll with generalization from camera
    procedure EnrollWithGeneralizationFromCamera(grayImage: TNImage;
      rgbImage: TNImage);

  public
    procedure AddToLog(str: String; addnewline: Boolean = true);
  end;

  TMatchingThread = class(TThread)
  private
    FTemplate: TArrayOfByte;
    procedure MatchToDB(features: TArrayOfByte);
  public
    property FeaturesToMatch: TArrayOfByte write FTemplate;
    procedure Execute; override;
  end;

var
  Form: TMainForm;
  gCameraMan: TCameraMan;
  gExtractor: TNLExtractor;
  gMatcher: TNMatcher;
  gDataBase: TDatabase;
  Counter: Integer;

implementation

{
$R *.dfm
}
// -----------------------------------------------------
// Misc methods
// -----------------------------------------------------

function BitmapResize(Bitmap: TBitmap; NewHeight: Integer;
  NewWidth: Integer): Boolean;
  function BitmapResizeInternal(BitmapSource: TBitmap; BitmapOut: TBitmap;
    NewHeight: Integer; NewWidth: Integer): Boolean;
  var
    inWidthOld: Integer;
    inHeightOld: Integer;
    Bitmap: TBitmap;
  begin
    Bitmap := TBitmap.Create;
    try
      try
        inWidthOld := BitmapSource.Width;
        inHeightOld := BitmapSource.Height;
        Bitmap.Width := NewWidth;
        Bitmap.Height := NewHeight;
        Bitmap.Palette := BitmapSource.Palette;
        SetStretchBltMode(Bitmap.Canvas.Handle, STRETCH_DELETESCANS);
        Bitmap.Canvas.Copyrect(Rect(0, 0, NewWidth, NewHeight),
          BitmapSource.Canvas, Rect(0, 0, inWidthOld, inHeightOld));
        Bitmap.Palette := BitmapSource.Palette;
        BitmapOut.Assign(Bitmap);
        Result := true;
      except
        Result := false;
        Raise ;
      end;
    finally
      FreeAndNil(Bitmap);
    end;
  end;

var
  BitmapOut: TBitmap;
begin
  BitmapOut := TBitmap.Create;
  try
    Result := BitmapResizeInternal(Bitmap, // BitmapSource : TBitmap;
      BitmapOut, // BitmapOut    : TBitmap;
      NewHeight, // NewHeight    : Integer;
      NewWidth); // NewWidth     : Integer): Boolean;
    if Result Then
    begin
      Bitmap.Assign(BitmapOut);
    end;
  finally
    FreeAndNil(BitmapOut);
  end;
end;

// -----------------------------------------------------
// TMatchingThread methods
// -----------------------------------------------------

procedure TMatchingThread.Execute;
begin
  if (Length(FTemplate) <> 0) then
    MatchToDB(FTemplate);
end;

procedure TMatchingThread.MatchToDB(features: TArrayOfByte);
var
  i: Integer;
  tmpMatchResult: TMatchResult;
  tmpArray: TArrayOfMatchResult;
  tmpInt: Integer;
  details: TNMMatchDetails;
begin
  // Start identification
  gMatcher.IdentifyStart(features);
  for i := 0 to gDataBase.GetCount - 1 do
  begin
    // Move to next template for identification
    tmpMatchResult.FSimilarity := gMatcher.IdentifyNext
      (gDataBase.GetTemplate(i).FTemplate, details);
    if (tmpMatchResult.FSimilarity > 0) then
    begin
      tmpInt := Length(tmpArray);
      SetLength(tmpArray, tmpInt + 1);
      tmpMatchResult.FID := gDataBase.GetTemplate(i).FID;
      tmpMatchResult.FFaceID := gDataBase.GetTemplate(i).FTemplateId;
      tmpArray[tmpInt] := tmpMatchResult;
    end;
  end;
  // End the identification
  gMatcher.IdentifyEnd;
  // Sort array of MatchResult
  QuickSort(tmpArray, 0, Length(tmpArray) - 1,
    tmpArray[Trunc(Length(tmpArray) / 2)]);
  SendMessage(Form.Handle, WM_PRINT_MESSAGE, Integer(tmpArray), 0);
end;

// -----------------------------------------------------
// Misc functions
// -----------------------------------------------------
procedure TMainForm.InitSettings();
begin
  FEnrollStreamLength := 10;
  FMatchingStreamLength := 3;
  FMatchingAttempts := 10;
  FTemplateCountForGeneralization := 3;
  FBackUppedMaxRecords := gExtractor.MaxRecordsInTemplate;
  FFileNameAsID := true;
  FFlipImageHorizontally := false;
  FFlipImageVertically := false;
  FSaveImages := true;
  FEnrollTemplateSize := nLetsLarge;
  FIdentifyTemplateSize := nLetsMedium;
end;

procedure TMainForm.AddToLog(str: String; addnewline: Boolean = true);
begin
  if (tbLog.Lines.Count > 100) then
    tbLog.Lines.Cl
...
...
(Not finished, please download and read the complete file)
			
...
Expand> <Close

Want complete source code? Download it here

Point(s): 2

Download
0 lines left, continue to read
Sponsored links

File list

Tips: You can preview the content of files by clicking file names^_^
Name Size Date
Aboutform.dcu7.81 kB29-05-10 03:22
AboutForm.dfm59.86 kB02-04-10 14:37
AboutForm.pas2.79 kB02-04-10 14:37
DataBase.dcu10.72 kB29-05-10 02:56
DataBase.pas7.02 kB02-04-10 14:37
NCore.dcu12.55 kB29-05-10 02:56
NCore.pas11.17 kB02-04-10 14:37
NDeviceManager.dcu24.08 kB29-05-10 02:56
NDeviceManager.pas20.58 kB26-05-10 01:21
NExtractors.dcu26.38 kB29-05-10 02:56
NExtractors.pas22.97 kB02-04-10 14:37
NImages.dcu18.89 kB29-05-10 02:56
NImages.pas16.86 kB02-04-10 14:37
NLicensing.dcu1.73 kB29-05-10 02:56
NLicensing.pas2.27 kB02-04-10 14:37
NMatchers.dcu10.16 kB29-05-10 02:56
NMatchers.pas8.69 kB02-04-10 14:37
NTemplates.dcu13.67 kB29-05-10 02:56
NTemplates.pas10.28 kB02-04-10 14:37
NUtils.dcu17.47 kB29-05-10 02:56
NUtils.pas14.14 kB02-04-10 14:37
SQLite3.dcu10.79 kB29-05-10 02:56
sqlite3.dll493.92 kB02-04-10 14:37
SQLite3.pas13.07 kB02-04-10 14:37
SQLiteTable3.dcu49.60 kB29-05-10 02:56
SQLiteTable3.pas44.43 kB02-04-10 14:37
<SQLite>0.00 B29-05-10 03:00
DataBase.pas.~1~7.02 kB02-04-10 14:37
DataBase.pas.~2~7.02 kB26-05-10 01:49
DataBase.pas.~3~7.03 kB26-05-10 01:51
NDeviceManager.pas.~1~20.57 kB02-04-10 14:37
<__history>0.00 B29-05-10 03:00
<Bibliotecas>0.00 B29-05-10 03:00
CameraForm.dcu7.54 kB29-05-10 03:22
CameraForm.dfm172.63 kB02-04-10 14:37
CameraForm.pas2.57 kB02-04-10 14:37
DataBase.dcu10.98 kB29-05-10 03:22
DataBase.pas7.02 kB02-04-10 14:37
EnrollmentForm.dcu4.85 kB29-05-10 03:22
EnrollmentForm.dfm171.08 kB02-04-10 14:37
EnrollmentForm.pas577.00 B02-04-10 14:37
FacesSamplePas.cfg473.00 B02-04-10 14:37
FacesSamplePas.dof2.57 kB02-04-10 14:37
FacesSamplePas.dpr1.00 kB02-04-10 14:37
FacesSamplePas.dproj5.96 kB29-05-10 03:20
FacesSamplePas.dproj.20074.74 kB02-04-10 14:37
FacesSamplePas.dproj.local62.00 B29-05-10 03:21
FacesSamplePas.identcache1.19 kB29-05-10 03:22
FacesSamplePas.res78.90 kB29-05-10 03:20
fPrincipal.dcu53.36 kB29-05-10 03:13
fPrincipal.dfm176.14 kB29-05-10 03:05
fPrincipal.pas47.37 kB29-05-10 03:05
MainForm.dcu53.56 kB29-05-10 03:22
MainForm.dfm176.34 kB29-05-10 02:38
MainForm.pas47.42 kB29-05-10 02:54
NCore.dcu12.56 kB29-05-10 03:15
NDeviceManager.dcu24.09 kB29-05-10 03:15
Neurotechnology.bmp19.17 kB02-04-10 14:37
Neurotechnology.ico77.80 kB02-04-10 14:37
NExtractors.dcu26.39 kB29-05-10 03:15
NImages.dcu18.90 kB29-05-10 03:15
NLicensing.dcu1.74 kB29-05-10 03:15
NMatchers.dcu10.17 kB29-05-10 03:15
NTemplates.dcu13.68 kB29-05-10 03:15
NUtils.dcu17.48 kB29-05-10 03:15
SettingsForm.dcu15.43 kB29-05-10 03:22
SettingsForm.dfm177.53 kB02-04-10 14:37
SettingsForm.pas7.09 kB02-04-10 14:37
SQLite3.dcu10.80 kB29-05-10 03:15
SQLiteTable3.dcu49.61 kB29-05-10 03:15
FacesSamplePas.dpr.~1~1.00 kB02-04-10 14:37
FacesSamplePas.dpr.~2~1.01 kB29-05-10 03:02
FacesSamplePas.dpr.~3~411.00 B29-05-10 03:02
fPrincipal.dfm.~1~176.34 kB29-05-10 02:38
fPrincipal.dfm.~2~176.35 kB29-05-10 03:02
fPrincipal.dfm.~3~176.32 kB29-05-10 03:04
fPrincipal.pas.~1~47.42 kB29-05-10 03:01
fPrincipal.pas.~2~47.59 kB29-05-10 03:02
fPrincipal.pas.~3~47.58 kB29-05-10 03:04
fPrincipal.pas.~4~47.43 kB29-05-10 03:05
MainForm.dfm.~1~176.32 kB02-04-10 14:37
MainForm.dfm.~2~176.34 kB26-05-10 01:10
MainForm.dfm.~3~176.34 kB26-05-10 01:45
MainForm.dfm.~4~176.35 kB26-05-10 23:51
MainForm.dfm.~5~176.35 kB27-05-10 01:38
MainForm.dfm.~6~176.35 kB29-05-10 01:37
MainForm.pas.~1~45.50 kB02-04-10 14:37
MainForm.pas.~2~45.50 kB26-05-10 01:26
MainForm.pas.~3~45.64 kB26-05-10 01:45
MainForm.pas.~4~47.41 kB27-05-10 00:51
MainForm.pas.~5~47.42 kB27-05-10 01:18
MainForm.pas.~6~47.42 kB29-05-10 01:40
<__history>0.00 B29-05-10 03:16
<Biometria>0.00 B0 0%
...
Sponsored links

MainForm.pas (1.58 MB)

Need 2 point
Your Point(s)

Your Point isn't enough.

Get point immediately by PayPal

More(Debit card / Credit card / PayPal Credit / Online Banking)

Submit your source codes. Get more point

LOGIN

Don't have an account? Register now
Need any help?
Mail to: support@codeforge.com

切换到中文版?

CodeForge Chinese Version
CodeForge English Version

Where are you going?

^_^"Oops ...

Sorry!This guy is mysterious, its blog hasn't been opened, try another, please!
OK

Warm tip!

CodeForge to FavoriteFavorite by Ctrl+D