fPrincipal.pas ( File view )

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


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


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

  TfrmPrincipal = 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;
    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);

    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);

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

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

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


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

function BitmapResize(Bitmap: TBitmap; NewHeight: Integer;
  NewWidth: Integer): Boolean;
  function BitmapResizeInternal(BitmapSource: TBitmap; BitmapOut: TBitmap;
    NewHeight: Integer; NewWidth: Integer): Boolean;
    inWidthOld: Integer;
    inHeightOld: Integer;
    Bitmap: TBitmap;
    Bitmap := TBitmap.Create;
        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;
        Result := true;
        Result := false;
        Raise ;

  BitmapOut: TBitmap;
  BitmapOut := TBitmap.Create;
    Result := BitmapResizeInternal(Bitmap, // BitmapSource : TBitmap;
      BitmapOut, // BitmapOut    : TBitmap;
      NewHeight, // NewHeight    : Integer;
      NewWidth); // NewWidth     : Integer): Boolean;
    if Result Then

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

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

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

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

procedure TfrmPrincipal.AddToLog(str: String; addnewline: Boolean = true);
  if (tbLog.Lines.Count > 100) then

  if (Length(tbLog.Text) > 0) and addnewline t
(Not finished, please download and read the complete file)
Expand> <Close

Want complete source code? Download it here

Point(s): 2

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

fPrincipal.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


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!

Warm tip!

CodeForge to FavoriteFavorite by Ctrl+D