www.pudn.com > facedetectDLL_expressions.zip > frmMain.frm
VERSION 5.00
Begin VB.Form frmMain
Caption = "openCV face detection"
ClientHeight = 6645
ClientLeft = 165
ClientTop = 735
ClientWidth = 7920
LinkTopic = "Form1"
ScaleHeight = 6645
ScaleWidth = 7920
StartUpPosition = 3 'Windows Default
Begin VB.PictureBox picFace
Height = 1800
Left = 5820
ScaleHeight = 1740
ScaleWidth = 1650
TabIndex = 16
Top = 3210
Width = 1710
End
Begin VB.CheckBox chkShowFeatures
Caption = "Show detected features"
Height = 450
Left = 5805
TabIndex = 13
Top = 5175
Width = 1920
End
Begin VB.PictureBox picMouth
Height = 495
Left = 6180
ScaleHeight = 435
ScaleWidth = 1080
TabIndex = 10
Top = 2445
Width = 1140
End
Begin VB.PictureBox picNose
Height = 600
Left = 6465
ScaleHeight = 540
ScaleWidth = 480
TabIndex = 9
Top = 1755
Width = 540
End
Begin VB.PictureBox picRightEye
Height = 645
Left = 6810
ScaleHeight = 585
ScaleWidth = 795
TabIndex = 8
Top = 1110
Width = 855
End
Begin VB.PictureBox picLeftEye
Height = 645
Left = 5730
ScaleHeight = 585
ScaleWidth = 825
TabIndex = 7
Top = 1110
Width = 885
End
Begin VB.PictureBox picObjectDetected
Height = 1170
Index = 3
Left = 3885
ScaleHeight = 1000
ScaleMode = 0 'User
ScaleWidth = 1000
TabIndex = 6
Top = 5010
Width = 1230
End
Begin VB.PictureBox picObjectDetected
Height = 1170
Index = 2
Left = 2610
ScaleHeight = 1000
ScaleMode = 0 'User
ScaleWidth = 1000
TabIndex = 5
Top = 5010
Width = 1230
End
Begin VB.PictureBox picObjectDetected
Height = 1170
Index = 1
Left = 1350
ScaleHeight = 1000
ScaleMode = 0 'User
ScaleWidth = 1000
TabIndex = 4
Top = 5010
Width = 1230
End
Begin VB.PictureBox picObjectDetected
Height = 1170
Index = 0
Left = 75
ScaleHeight = 1000
ScaleMode = 0 'User
ScaleWidth = 1000
TabIndex = 3
Top = 5010
Width = 1230
End
Begin VB.CommandButton cmdStop
Caption = "Stop"
Height = 375
Left = 1245
TabIndex = 2
Top = 60
Width = 975
End
Begin VB.Timer timGrab
Interval = 50
Left = 4485
Top = 45
End
Begin VB.PictureBox Eye
AutoRedraw = -1 'True
Height = 4260
Index = 0
Left = 60
ScaleHeight = 280
ScaleMode = 3 'Pixel
ScaleWidth = 347
TabIndex = 1
Top = 585
Width = 5265
End
Begin VB.CommandButton Preview
Caption = "&Start"
Height = 375
Left = 105
TabIndex = 0
Top = 60
Width = 975
End
Begin VB.Label lblMouthOpen
Caption = "0"
Height = 285
Left = 7185
TabIndex = 15
Top = 6120
Width = 375
End
Begin VB.Label lblSmile
Caption = "0"
Height = 285
Left = 6735
TabIndex = 14
Top = 6105
Width = 375
End
Begin VB.Label lblEyebrows
Caption = "0"
Height = 285
Left = 5775
TabIndex = 12
Top = 6105
Width = 810
End
Begin VB.Label Label1
Caption = "Facial Features"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 5925
TabIndex = 11
Top = 645
Width = 1710
End
Begin VB.Menu mnuFile
Caption = "File"
Begin VB.Menu mnuChoose
Caption = "Choose Camera"
End
Begin VB.Menu mnuExit
Caption = "Exit"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Rodney robot - motion demo
'Copyright (C) 2003 Bob Mottram
'
'This program is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published by
'the Free Software Foundation; either version 2 of the License, or
'(at your option) any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'GNU General Public License for more details.
'
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'NOTE: Make sure that you register CapStill.dll and FSFWrap.dll before running
' this program. You can do this using the following commandline
' regsvr32
' After the program is run it creates a file called filters.txt, which
' lists out all the WDM filters. Make sure that the filter name is
' correct for the cameras that you're using
'
' You will also need to have the MS Visual C++ 6.0 runtime installed
Option Explicit
'dimensions of the stereo image
Dim IMAGE_WIDTH As Long
Dim IMAGE_HEIGHT As Long
Const DETECTED_OBJECT_WIDTH = 30
Const DETECTED_OBJECT_HEIGHT = 30
Const DETECTED_EYE_WIDTH = 30
Const DETECTED_EYE_HEIGHT = 40
Const DETECTED_NOSE_WIDTH = 10
Const DETECTED_NOSE_HEIGHT = 20
Const DETECTED_MOUTH_WIDTH = 20
Const DETECTED_MOUTH_HEIGHT = 15
Dim img As New ClassImage
Dim imgEye As New ClassImage
Dim imgNose As New ClassImage
Dim imgMouth As New ClassImage
Dim initFaces As Boolean
'the busy flag just prevents VB from tripping over itself using the timer
Dim busy As Boolean
Dim gGraph(2) As IMediaControl
Dim gRegFilters(2) As Object
Dim gCapStill(2) As VBGrabber
Dim initialised(2) As Boolean
Dim hMemDc(2) As Long
'bitmaps for left and right images
Dim bmp() As Byte
Dim initBitmap As Boolean
Dim NoOfObjects As Integer
Dim camerasRunning As Boolean
Dim bma As IBitmapAccess
'GDI functions to draw a DIBSection into a DC
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hbitmap As Long) As Long
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal Width As Long, ByVal Height As Long, _
ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal mode As Long) _
As Long
Private Declare Sub DeleteDC Lib "gdi32" _
(ByVal hdc As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Dest As Any, src As Any, ByVal count As Long)
Private Sub GrabNow(cameraIndex As Integer)
On Error GoTo GrabNow_err
If (initialised(cameraIndex)) Then
Set bma = gCapStill(cameraIndex).CapToMem
Call ShowBitmap(bma, cameraIndex)
End If
GrabNow_exit:
Exit Sub
GrabNow_err:
Resume GrabNow_exit
End Sub
Private Sub CameraPreview(DriverName As String, cameraIndex As Integer)
On Error GoTo CameraPreview_err
Dim i As Integer
Dim index As Integer
Dim xbar As CrossbarInfo
Dim pinOut As IPinInfo
Dim idx As Long
Dim filter As IRegFilterInfo
Dim fGrab As IFilterInfo
Dim fSrc As IFilterInfo
Dim pin As String
Dim found As Boolean
Dim pSC As StreamConfig
Dim pinIn As IPinInfo
Dim ppropOut As PinPropInfo
Dim strFilters As String
Dim pinErr As Boolean
pinErr = False
'make a new graph
Set gGraph(cameraIndex) = Nothing
Set gCapStill(cameraIndex) = Nothing
Set gGraph(cameraIndex) = New FilgraphManager
Set gRegFilters(cameraIndex) = gGraph(cameraIndex).RegFilterCollection
'add the grabber including vb wrapper and default props
found = False
i = 0
While (i < gRegFilters(cameraIndex).count) And (Not found)
Call gRegFilters(cameraIndex).Item(i, filter)
If (filter.Name = "SampleGrabber") Then
filter.filter fGrab
'wrap this filter in the capstill vb wrapper
'also sets rgb-24 media type and other properties
Set gCapStill(cameraIndex) = New VBGrabber
gCapStill(cameraIndex).FilterInfo = fGrab
found = True
End If
i = i + 1
Wend
'add the selected source filter
'WDM drivers for the cameras can be identified by the word "QuickCam" in their title
index = 0
found = False
i = 0
While (i < gRegFilters(cameraIndex).count) And (Not found)
Call gRegFilters(cameraIndex).Item(i, filter)
If (InStr(LCase(filter.Name), LCase(DriverName)) > 0) Then
If (index = cameraIndex) Then
filter.filter fSrc
found = True
End If
index = index + 1
End If
i = i + 1
Wend
'find first output on src
found = False
i = 0
While (i < fSrc.Pins.count) And (Not found)
Call fSrc.Pins.Item(i, pinOut)
If (pinOut.Direction = 1) Then
found = True
End If
i = i + 1
Wend
'restore specified file before dlg
Set pSC = New StreamConfig
pSC.pin = pinOut
If (pSC.SupportsConfig) Then
If (Dir$("mtsave.mt") <> "") Then
'pSC.Restore ("mtsave.mt")
End If
End If
'show format of output pin before rendering
Set ppropOut = New PinPropInfo
ppropOut.pin = pinOut
'find first input on grabber and connect
found = False
i = 0
While (i < fGrab.Pins.count) And (Not found)
Call fGrab.Pins.Item(i, pinIn)
If (pinIn.Direction = 0) Then
pinErr = True
pinOut.Connect pinIn
pinErr = False
found = True
End If
i = i + 1
Wend
' find grabber output pin and render
found = False
i = 0
While (i < fGrab.Pins.count) And (Not found)
Call fGrab.Pins.Item(i, pinOut)
If (pinOut.Direction = 1) Then
pinOut.Render
found = True
End If
i = i + 1
Wend
' run graph and we are successfully in preview mode
Call gGraph(cameraIndex).Run
'putting a delay here just gives the camera some time to
'initialise before trying to grab frames from it
Dim currTime As Long
Dim startTime As Long
currTime = Timer
startTime = currTime
While (currTime < startTime + 5)
DoEvents
currTime = Timer
Wend
'camera has been initialised
initialised(cameraIndex) = True
CameraPreview_exit:
Exit Sub
CameraPreview_err:
If (pinErr) Then
Resume CameraPreview_exit
End If
MsgBox "frmQuickCamStereo/CameraPreview/" & Err & "/" & Error$(Err)
Resume CameraPreview_exit
End Sub
Private Sub cmdStop_Click()
Dim i As Integer
For i = 0 To 1
If (initialised(i)) Then
initialised(i) = False
Call gGraph(i).Stop
Set gGraph(i) = Nothing
Set gRegFilters(i) = Nothing
Set gCapStill(i) = Nothing
End If
Next
camerasRunning = False
End Sub
Private Sub Form_Load()
IMAGE_WIDTH = 500
IMAGE_HEIGHT = 400
busy = False
initBitmap = False
Filter_Name = ""
Call loadSettings
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call saveSettings
End Sub
Private Sub Label2_Click()
End Sub
Private Sub mnuChoose_Click()
frmFilter.Show 1
End Sub
Private Sub Preview_Click()
'preview using the appropriate WDM filter name for the cameras
'if in doubt about the filter name have a look through filters.txt
camerasRunning = False
If (Filter_Name = "") Then
frmFilter.Show 1
End If
Call CameraPreview(Filter_Name, 0)
'ADS Pyro 1394
'Call CameraPreview("1394 Desktop Video Camera", 0)
'Logitech Quickcam Express
'Call CameraPreview("quickcam", 0)
'l'espion camera
'Call CameraPreview("USB dual-mode camera", 0)
'Zoomcam USB
'Call CameraPreview("zoom", 0)
camerasRunning = True
End Sub
Private Sub SaveBitmap(cameraIndex As Integer, filename As String)
If (initialised(cameraIndex)) Then
gCapStill(cameraIndex).filename = filename
gCapStill(cameraIndex).CaptureStill
End If
End Sub
Private Sub ShowBitmap(bma As IBitmapAccess, cameraIndex As Integer)
'set correct size of image and then
'BitBlt to the picture control's HDC
Dim hbm As Long
Dim hOldBM As Long
Dim initEye(2) As Boolean
Static flip(2) As Boolean
If (Not initEye(cameraIndex)) Then
initEye(cameraIndex) = True
Eye(cameraIndex).Width = bma.Width * Screen.TwipsPerPixelX
Eye(cameraIndex).Height = bma.Height * Screen.TwipsPerPixelY
hMemDc(cameraIndex) = CreateCompatibleDC(Eye(cameraIndex).hdc)
End If
hbm = bma.DIBSection
hOldBM = SelectObject(hMemDc(cameraIndex), hbm)
BitBlt Eye(cameraIndex).hdc, 0, 0, bma.Width, bma.Height, hMemDc(cameraIndex), 0, 0, &HCC0020
SelectObject hMemDc(cameraIndex), hOldBM
Eye(cameraIndex).Refresh
End Sub
Private Sub timGrab_Timer()
'Eye eye
Dim i As Integer
Dim x(2) As Long
Dim y(2) As Long
Dim dist As Single
Dim shoulderLevel As Long
Dim headHorizontal As Long
Dim headWidth As Long
Dim flow_x As Single
Dim flow_y As Single
If (camerasRunning) And (Not busy) Then
busy = True
'grab image from the camera
Call GrabNow(0)
Call detectFaces(bma)
DoEvents
busy = False
End If
End Sub
Public Sub showSquare(inputImage As PictureBox, tx As Long, ty As Long, bx As Long, by As Long)
'shows the area covered by the bounding box
Dim txx As Integer
Dim tyy As Integer
Dim w As Integer
Dim h As Integer
Dim rc As Long
Dim sx As Integer
Dim sy As Integer
'transparent fill style
inputImage.FillStyle = 1
inputImage.DrawWidth = 1
inputImage.ScaleWidth = 1000
inputImage.ScaleHeight = 1000
txx = (CInt(tx) * inputImage.ScaleWidth) / IMAGE_WIDTH
tyy = (CInt(ty) * inputImage.ScaleHeight) / IMAGE_HEIGHT
sx = (CInt(bx - tx) * inputImage.ScaleWidth) / IMAGE_WIDTH
sy = (CInt(by - ty) * inputImage.ScaleHeight) / IMAGE_HEIGHT
inputImage.Line (txx, tyy)-(txx + sx, tyy + sy), RGB(0, 255, 0), B
End Sub
Private Sub detectFaces(bma As IBitmapAccess)
Dim cDib As New cDIBsection
Dim tSA As SAFEARRAY2D
Dim bDib() As Byte
Dim x As Integer
Dim y As Integer
Dim c As Integer
Dim n As Long
Dim xx As Integer
Dim yy As Integer
Dim hght As Integer
cDib.Create bma.Width, bma.Height
cDib.LoadPictureBlt Eye(0).hdc, 0, 0, bma.Width, bma.Height
If (Not initFaces) Then
Call init(IMAGE_WIDTH, IMAGE_HEIGHT)
ReDim bmp(IMAGE_WIDTH * IMAGE_HEIGHT * 3)
End If
If (cDib.Width > 0) Then
With tSA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = cDib.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = cDib.BytesPerScanLine
.pvData = cDib.DIBSectionBitsPtr
End With
CopyMemory ByVal VarPtrArray(bDib), VarPtr(tSA), 4
hght = cDib.Height - 1
'If (hght > 400) Then hght = 400
n = 0
For y = IMAGE_HEIGHT - 1 To 0 Step -1
yy = y / IMAGE_HEIGHT * hght
For x = 0 To IMAGE_WIDTH - 1
xx = x / IMAGE_WIDTH * cDib.Width
For c = 0 To 2
bmp(n) = bDib((xx * 3) + c, yy)
n = n + 1
Next
Next
Next
NoOfObjects = RCobj_detectfaces(bmp)
'tidy up
CopyMemory ByVal VarPtrArray(bDib), 0&, 4
End If
Set cDib = Nothing
If (NoOfObjects > 0) Then
Call showObjects
If (chkShowFeatures.value <> 0) Then
Call showdetectedfeatures
End If
End If
End Sub
Private Sub init(pic_width As Long, pic_height As Long)
Dim success As Long
IMAGE_WIDTH = pic_width
IMAGE_HEIGHT = pic_height
Eye(0).ScaleWidth = pic_width
Eye(0).ScaleHeight = pic_height
'initialise the face detector
success = RCobj_InitFaceDetect(pic_width, pic_height)
'set a border around the detected faces
'Call RCobj_setBorder(0, pic_height / 20, pic_height / 10)
Call img.init(DETECTED_OBJECT_WIDTH, DETECTED_OBJECT_HEIGHT)
Call imgEye.init(DETECTED_EYE_WIDTH, DETECTED_EYE_HEIGHT)
Call imgNose.init(DETECTED_NOSE_WIDTH, DETECTED_NOSE_HEIGHT)
Call imgMouth.init(DETECTED_MOUTH_WIDTH, DETECTED_MOUTH_HEIGHT)
picLeftEye.ScaleWidth = DETECTED_EYE_WIDTH
picLeftEye.ScaleHeight = DETECTED_EYE_HEIGHT
picRightEye.ScaleWidth = DETECTED_EYE_WIDTH
picRightEye.ScaleHeight = DETECTED_EYE_HEIGHT
picNose.ScaleWidth = DETECTED_NOSE_WIDTH
picNose.ScaleHeight = DETECTED_NOSE_HEIGHT
picMouth.ScaleWidth = DETECTED_MOUTH_WIDTH
picMouth.ScaleHeight = DETECTED_MOUTH_HEIGHT
initFaces = True
End Sub
Private Sub showObjects()
On Error GoTo showObjects_err
Dim i As Long
Dim x As Integer
Dim y As Integer
Dim dX As Integer
Dim dy As Integer
Dim max As Integer
Dim tx As Long
Dim ty As Long
Dim bx As Long
Dim by As Long
Dim xx As Integer
Dim yy As Integer
Dim n As Long
Dim pval(3) As Byte
Dim lefteye_x As Long
Dim lefteye_y As Long
Dim lefteye_width As Long
Dim lefteyebrow As Long
Dim righteye_x As Long
Dim righteye_y As Long
Dim righteye_width As Long
Dim righteyebrow As Long
Dim nose_x As Long
Dim nose_y As Long
Dim eyebrow_elevation As Long
Dim mouth_open As Long
Dim gazeLateral As Long
Const showFeatureDetections = False
Dim leftEyeOuter As Long
Dim leftEyeInner As Long
Dim leftEyePupil_x As Long
Dim leftEyePupil_y As Long
Dim leftEyebrow_y As Long
Dim rightEyeOuter As Long
Dim rightEyeInner As Long
Dim rightEyePupil_x As Long
Dim rightEyePupil_y As Long
Dim rightEyebrow_y As Long
Dim smile As Long
Dim mouthOpen As Long
Dim mouthOpenWidth As Long
max = NoOfObjects
If (max > 4) Then max = 4
For i = 0 To max - 1
Call RCobj_getObject(i, tx, ty, bx, by)
dX = bx - tx
dy = by - ty
'get the facial feature points
Call RCobj_getFacialFeatures(i, leftEyeOuter, leftEyeInner, leftEyePupil_x, leftEyePupil_y, leftEyebrow_y, rightEyeOuter, rightEyeInner, rightEyePupil_x, rightEyePupil_y, rightEyebrow_y, smile, mouthOpen, mouthOpenWidth)
'show the detected face
For y = 0 To DETECTED_OBJECT_HEIGHT - 1
yy = ty + (y / DETECTED_OBJECT_HEIGHT * dy)
For x = 0 To DETECTED_OBJECT_WIDTH - 1
xx = tx + (x / DETECTED_OBJECT_WIDTH * dX)
n = (yy * (IMAGE_WIDTH * 3)) + (xx * 3)
pval(0) = bmp(n + 2)
pval(1) = bmp(n + 1)
pval(2) = bmp(n + 0)
Call img.setPoint(x, y, 0, pval(0))
Call img.setPoint(x, y, 1, pval(1))
Call img.setPoint(x, y, 2, pval(2))
Next
Next
Call img.Show(picObjectDetected(i))
If (i = 0) Then
'show the facial expression
Call showFace(picFace, CInt(leftEyeOuter), CInt(leftEyeInner), CInt(leftEyePupil_x), CInt(leftEyePupil_y), CInt(leftEyebrow_y), CInt(rightEyeOuter), CInt(rightEyeInner), CInt(rightEyePupil_x), CInt(rightEyePupil_y), CInt(rightEyebrow_y), CInt(smile), CInt(mouthOpen), CInt(mouthOpenWidth))
End If
Next
showObjects_exit:
Exit Sub
showObjects_err:
If (Err = 6) Then
Resume Next
End If
MsgBox "frmMain/showObjects/" & Err & "/" & Error$(Err)
Resume showObjects_exit
End Sub
Private Sub showdetectedfeatures()
On Error GoTo showObjects_err
Dim i As Long
Dim tx As Long
Dim ty As Long
Dim bx As Long
Dim by As Long
Dim x As Integer
Dim y As Integer
Dim xx As Integer
Dim yy As Integer
Dim dX As Integer
Dim dy As Integer
Dim n As Long
Dim max As Integer
Dim lateral_symetry As Long
Dim leftpoint_x As Long
Dim rightpoint_x As Long
Dim mouth_y As Long
Dim mouth_width As Long
Dim lateral As Integer
Dim lefteye As Integer
Dim righteye As Integer
Dim lefteyeY As Integer
Dim righteyeY As Integer
Dim leftpoint_y As Long
Dim rightpoint_y As Long
Dim pval(3) As Byte
Dim gazeLateral As Integer
Dim mouthY As Integer
Dim mouthWidth As Integer
Dim noseY As Integer
Dim noseX As Integer
Dim sizeScale As Single
Dim gazedirection As Long
Dim point_x As Integer
Dim point_y As Integer
Dim px As Integer
Dim pxx As Integer
Dim mouthOpenPercent As Integer
Dim leftEyeCorner(2) As Integer
Dim rightEyeCorner(2) As Integer
Dim eyesY(2) As Integer
Dim minY As Integer
Dim maxY As Integer
Dim txx As Integer
Dim tyy As Integer
Dim bxx As Integer
Dim txx2 As Integer
Dim eyeCentre(2) As Integer
Dim eyebrow_y(2) As Integer
Const showFeatureDetections = False
max = NoOfObjects
If (max > 4) Then max = 4
For i = 0 To max - 1
Call RCobj_getObject(i, tx, ty, bx, by)
Call RCobj_detectfeatures(i, lateral_symetry, leftpoint_x, rightpoint_x, leftpoint_y, rightpoint_y, mouth_y, mouth_width, gazedirection)
lateral = DETECTED_OBJECT_WIDTH * CInt(lateral_symetry) / 100
lefteye = DETECTED_OBJECT_WIDTH * leftpoint_x / 100
righteye = DETECTED_OBJECT_WIDTH * rightpoint_x / 100
lefteyeY = DETECTED_OBJECT_HEIGHT * leftpoint_y / 100
righteyeY = DETECTED_OBJECT_HEIGHT * rightpoint_y / 100
mouthY = DETECTED_OBJECT_HEIGHT * mouth_y / 100
mouthWidth = DETECTED_OBJECT_WIDTH * mouth_width / 100
noseY = DETECTED_OBJECT_HEIGHT / 2
noseX = DETECTED_OBJECT_WIDTH / 2
dX = bx - tx
dy = by - ty
'you may need to tinker with this scaling depending upon image resolution
sizeScale = dX / IMAGE_WIDTH * 3
For y = 0 To DETECTED_OBJECT_HEIGHT - 1
yy = ty + (y / DETECTED_OBJECT_HEIGHT * dy)
For x = 0 To DETECTED_OBJECT_WIDTH - 1
xx = tx + (x / DETECTED_OBJECT_WIDTH * dX)
n = (yy * (IMAGE_WIDTH * 3)) + (xx * 3)
If ((showFeatureDetections) And (x = lateral) And (y > (DETECTED_OBJECT_HEIGHT / 2) - 2) And (y < (DETECTED_OBJECT_HEIGHT / 2) + 2)) Or _
((showFeatureDetections) And (x > lefteye - 4) And (x < lefteye + 3) And (y > lefteyeY - 3) And (y < lefteyeY + 3)) Or ((showFeatureDetections) And (x > righteye - 3) And (x < righteye + 4) And (y > righteyeY - 3) And (y < righteyeY + 3)) Or _
((showFeatureDetections) And (y > mouthY - 3) And (y < mouthY + 3) And (x > lateral - (mouthWidth / 2)) And (x < lateral + (mouthWidth / 2))) Then
pval(0) = 0
pval(1) = 255
pval(2) = 0
Else
pval(0) = bmp(n + 2)
pval(1) = bmp(n + 1)
pval(2) = bmp(n + 0)
End If
Call img.setPoint(x, y, 0, pval(0))
Call img.setPoint(x, y, 1, pval(1))
Call img.setPoint(x, y, 2, pval(2))
Next
Next
Call img.Show(picObjectDetected(i))
'show left eye
For y = 0 To DETECTED_EYE_HEIGHT - 1
yy = ty + ((lefteyeY * dy) / DETECTED_OBJECT_HEIGHT) + ((y - (DETECTED_EYE_HEIGHT / 2)) * 1 * sizeScale)
For x = 0 To DETECTED_EYE_WIDTH - 1
xx = tx + ((lefteye * dX) / DETECTED_OBJECT_WIDTH) + ((x - (DETECTED_EYE_WIDTH / 2)) * 2 * sizeScale)
n = (yy * (IMAGE_WIDTH * 3)) + (xx * 3)
pval(0) = bmp(n + 2)
pval(1) = bmp(n + 1)
pval(2) = bmp(n + 0)
Call imgEye.setPoint(x, y, 0, pval(0))
Call imgEye.setPoint(x, y, 1, pval(1))
Call imgEye.setPoint(x, y, 2, pval(2))
Next
Next
'centre of left eye
Call imgEye.CG(0, DETECTED_EYE_HEIGHT / 2, DETECTED_EYE_WIDTH - 1, DETECTED_EYE_HEIGHT - 1, 0, 0, 0, point_x, point_y, 255)
eyesY(0) = point_y
'inner left eye
px = point_x
Call imgEye.CG(px, DETECTED_EYE_HEIGHT / 2, DETECTED_EYE_WIDTH - 1, DETECTED_EYE_HEIGHT - 1, 0, 0, 0, point_x, point_y, 255 * 3)
'Call imgEye.setPoint(point_x, point_y, 0, 0)
'Call imgEye.setPoint(point_x, point_y, 1, 255)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
rightEyeCorner(0) = point_x
'outer left eye
pxx = px - 3
If (pxx < 0) Then pxx = 0
Call imgEye.CG(0, DETECTED_EYE_HEIGHT / 2, pxx, DETECTED_EYE_HEIGHT - 1, 0, 0, 0, point_x, point_y, 255 * 2)
'Call imgEye.setPoint(point_x, point_y, 0, 0)
'Call imgEye.setPoint(point_x, point_y, 1, 255)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
leftEyeCorner(0) = point_x
minY = eyesY(0) - (DETECTED_EYE_HEIGHT / 8)
maxY = eyesY(0) + (DETECTED_EYE_HEIGHT / 8)
If (minY < 0) Then minY = 0
If (maxY >= DETECTED_EYE_HEIGHT) Then maxY = DETECTED_EYE_HEIGHT - 1
'left eye centre
Call imgEye.CG(leftEyeCorner(0), minY, rightEyeCorner(0), maxY, 0, 0, 0, point_x, point_y, 255)
If (point_x < leftEyeCorner(0) + 3) Then point_x = leftEyeCorner(0) + 3
If (point_x > rightEyeCorner(0) - 3) Then point_x = rightEyeCorner(0) - 3
eyeCentre(0) = point_x
For x = point_x - 1 To point_x + 1
'Call imgEye.setPoint(x, point_y, 0, 0)
'Call imgEye.setPoint(x, point_y, 1, 255)
'Call imgEye.setPoint(x, point_y, 2, 0)
Next
For y = point_y - 1 To point_y + 1
'Call imgEye.setPoint(point_x, y, 0, 0)
'Call imgEye.setPoint(point_x, y, 1, 255)
'Call imgEye.setPoint(point_x, y, 2, 0)
Next
'left eye direction
Call imgEye.CG(leftEyeCorner(0), minY, rightEyeCorner(0), maxY, 255, 255, 255, point_x, point_y, 200 * 3)
'Call imgEye.setPoint(point_x, point_y, 0, 255)
'Call imgEye.setPoint(point_x, point_y, 1, 0)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
'centre of left eyebrow
Call imgEye.CG(0, 0, DETECTED_EYE_WIDTH - 1, DETECTED_EYE_HEIGHT / 2, 0, 0, 0, point_x, point_y, 255)
'Call imgEye.setPoint(point_x, point_y, 0, 0)
'Call imgEye.setPoint(point_x, point_y, 1, 255)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
eyebrow_y(0) = point_y
Call imgEye.Show(picLeftEye)
picLeftEye.FillStyle = 1
picLeftEye.DrawStyle = 0
'txx = (leftEyeCorner(0) * picLeftEye.ScaleWidth) / DETECTED_EYE_WIDTH
'bxx = (rightEyeCorner(0) * picLeftEye.ScaleWidth) / DETECTED_EYE_WIDTH
'picLeftEye.Circle (txx + ((bxx - txx) / 2), (eyesY(0) * picLeftEye.ScaleHeight) / DETECTED_EYE_HEIGHT), (bxx - txx) / 2, RGB(255, 255, 255), 0, 6.2, 0.5
'txx2 = (eyeCentre(0) * picLeftEye.ScaleWidth) / DETECTED_EYE_WIDTH
'picLeftEye.Circle (txx2, (eyesY(0) * picLeftEye.ScaleHeight) / DETECTED_EYE_HEIGHT), (bxx - txx) / 4, RGB(255, 255, 255), 0, 6.2, 0.99
'txx2 = (point_x * picLeftEye.ScaleWidth) / DETECTED_EYE_WIDTH
'tyy = (point_y * picLeftEye.ScaleHeight) / DETECTED_EYE_HEIGHT
'picLeftEye.Circle (txx2, tyy), (bxx - txx) * 0.8, RGB(255, 255, 255), 0, 3.14, 0.1
'show right eye
For y = 0 To DETECTED_EYE_HEIGHT - 1
yy = ty + ((righteyeY * dy) / DETECTED_OBJECT_HEIGHT) + ((y - (DETECTED_EYE_HEIGHT / 2)) * 1 * sizeScale)
For x = 0 To DETECTED_EYE_WIDTH - 1
xx = tx + ((righteye * dX) / DETECTED_OBJECT_WIDTH) + ((x - (DETECTED_EYE_WIDTH / 2)) * 2 * sizeScale)
n = (yy * (IMAGE_WIDTH * 3)) + (xx * 3)
pval(0) = bmp(n + 2)
pval(1) = bmp(n + 1)
pval(2) = bmp(n + 0)
Call imgEye.setPoint(x, y, 0, pval(0))
Call imgEye.setPoint(x, y, 1, pval(1))
Call imgEye.setPoint(x, y, 2, pval(2))
Next
Next
'centre of right eye
Call imgEye.CG(0, DETECTED_EYE_HEIGHT / 2, DETECTED_EYE_WIDTH - 1, DETECTED_EYE_HEIGHT - 1, 0, 0, 0, point_x, point_y, 255)
eyesY(1) = point_y
'inner right eye
px = point_x
Call imgEye.CG(0, DETECTED_EYE_HEIGHT / 2, px, DETECTED_EYE_HEIGHT - 1, 0, 0, 0, point_x, point_y, 255 * 3)
'Call imgEye.setPoint(point_x, point_y, 0, 0)
'Call imgEye.setPoint(point_x, point_y, 1, 255)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
leftEyeCorner(1) = point_x
'outer right eye
pxx = px + 3
If (pxx >= DETECTED_EYE_WIDTH) Then pxx = DETECTED_EYE_WIDTH - 1
Call imgEye.CG(pxx, DETECTED_EYE_HEIGHT / 2, DETECTED_EYE_WIDTH - 1, DETECTED_EYE_HEIGHT - 1, 0, 0, 0, point_x, point_y, 255 * 2)
'Call imgEye.setPoint(point_x, point_y, 0, 0)
'Call imgEye.setPoint(point_x, point_y, 1, 255)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
rightEyeCorner(1) = point_x
minY = eyesY(1) - (DETECTED_EYE_HEIGHT / 8)
maxY = eyesY(1) + (DETECTED_EYE_HEIGHT / 8)
If (minY < 0) Then minY = 0
If (maxY >= DETECTED_EYE_HEIGHT) Then maxY = DETECTED_EYE_HEIGHT - 1
'centre of right eye
Call imgEye.CG(leftEyeCorner(1), minY, rightEyeCorner(1), maxY, 0, 0, 0, point_x, point_y, 255)
If (point_x = 0) Then point_x = (eyeCentre(0) - leftEyeCorner(0)) + leftEyeCorner(1)
If (point_x < leftEyeCorner(1) + 3) Then point_x = leftEyeCorner(1) + 3
If (point_x > rightEyeCorner(1) - 3) Then point_x = rightEyeCorner(1) - 3
eyeCentre(1) = point_x
For x = point_x - 1 To point_x + 1
'Call imgEye.setPoint(x, point_y, 0, 0)
'Call imgEye.setPoint(x, point_y, 1, 255)
'Call imgEye.setPoint(x, point_y, 2, 0)
Next
For y = point_y - 1 To point_y + 1
'Call imgEye.setPoint(point_x, y, 0, 0)
'Call imgEye.setPoint(point_x, y, 1, 255)
'Call imgEye.setPoint(point_x, y, 2, 0)
Next
'right eye direction
Call imgEye.CG(leftEyeCorner(1), minY, rightEyeCorner(1), maxY, 255, 255, 255, point_x, point_y, 200 * 3)
'Call imgEye.setPoint(point_x, point_y, 0, 255)
'Call imgEye.setPoint(point_x, point_y, 1, 0)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
'centre of right eyebrow
Call imgEye.CG(0, 0, DETECTED_EYE_WIDTH - 1, DETECTED_EYE_HEIGHT / 2, 0, 0, 0, point_x, point_y, 255)
'Call imgEye.setPoint(point_x, point_y, 0, 0)
'Call imgEye.setPoint(point_x, point_y, 1, 255)
'Call imgEye.setPoint(point_x, point_y, 2, 0)
eyebrow_y(1) = point_y
Call imgEye.Show(picRightEye)
picLeftEye.FillStyle = 1
picLeftEye.DrawStyle = 0
'txx = (leftEyeCorner(1) * picRightEye.ScaleWidth) / DETECTED_EYE_WIDTH
'bxx = (rightEyeCorner(1) * picRightEye.ScaleWidth) / DETECTED_EYE_WIDTH
'picRightEye.Circle (txx + ((bxx - txx) / 2), (eyesY(1) * picRightEye.ScaleHeight) / DETECTED_EYE_HEIGHT), (bxx - txx) / 2, RGB(255, 255, 255), 0, 6.2, 0.5
'txx2 = (eyeCentre(1) * picRightEye.ScaleWidth) / DETECTED_EYE_WIDTH
'picRightEye.Circle (txx2, (eyesY(1) * picLeftEye.ScaleHeight) / DETECTED_EYE_HEIGHT), (bxx - txx) / 4, RGB(255, 255, 255), 0, 6.2, 0.99
'txx2 = (point_x * picRightEye.ScaleWidth) / DETECTED_EYE_WIDTH
'tyy = (point_y * picRightEye.ScaleHeight) / DETECTED_EYE_HEIGHT
'picRightEye.Circle (txx2, tyy), (bxx - txx) * 0.8, RGB(255, 255, 255), 0, 3.14, 0.1
'show nose
For y = 0 To DETECTED_NOSE_HEIGHT - 1
yy = ty + ((noseY * dy) / DETECTED_OBJECT_HEIGHT) + ((y - (DETECTED_NOSE_HEIGHT / 2)) * 4 * sizeScale)
For x = 0 To DETECTED_NOSE_WIDTH - 1
xx = tx + ((noseX * dX) / DETECTED_OBJECT_WIDTH) + ((x - (DETECTED_NOSE_WIDTH / 2)) * 3 * sizeScale)
n = (yy * (IMAGE_WIDTH * 3)) + (xx * 3)
pval(0) = bmp(n + 2)
pval(1) = bmp(n + 1)
pval(2) = bmp(n + 0)
Call imgNose.setPoint(x, y, 0, pval(0))
Call imgNose.setPoint(x, y, 1, pval(1))
Call imgNose.setPoint(x, y, 2, pval(2))
Next
Next
'nose tip
Call imgNose.CG(0, DETECTED_NOSE_HEIGHT / 2, DETECTED_NOSE_WIDTH - 1, DETECTED_NOSE_HEIGHT - 1, 0, 0, 0, point_x, point_y, 255)
Call imgNose.setPoint(DETECTED_NOSE_WIDTH - 1 - point_x, point_y, 0, 0)
Call imgNose.setPoint(DETECTED_NOSE_WIDTH - 1 - point_x, point_y, 1, 255)
Call imgNose.setPoint(DETECTED_NOSE_WIDTH - 1 - point_x, point_y, 2, 0)
Call imgNose.Show(picNose)
'show mouth
For y = 0 To DETECTED_MOUTH_HEIGHT - 1
yy = ty + (mouthY / DETECTED_OBJECT_HEIGHT * dy) + ((y - (DETECTED_MOUTH_HEIGHT / 2)) * 2 * sizeScale)
For x = 0 To DETECTED_MOUTH_WIDTH - 1
xx = tx + (noseX / DETECTED_OBJECT_WIDTH * dX) + ((x - (DETECTED_MOUTH_WIDTH / 2)) * 4 * sizeScale)
n = (yy * (IMAGE_WIDTH * 3)) + (xx * 3)
pval(0) = bmp(n + 2)
pval(1) = bmp(n + 1)
pval(2) = bmp(n + 0)
Call imgMouth.setPoint(x, y, 0, pval(0))
Call imgMouth.setPoint(x, y, 1, pval(1))
Call imgMouth.setPoint(x, y, 2, pval(2))
Next
Next
'Call imgMouth.CG(0, 0, DETECTED_MOUTH_WIDTH / 3, DETECTED_MOUTH_HEIGHT - 1, 0, 0, 0, point_x, point_y)
'Call imgMouth.setPoint(point_x, point_y, 0, 0)
'Call imgMouth.setPoint(point_x, point_y, 1, 255)
'Call imgMouth.setPoint(point_x, point_y, 2, 0)
'Call imgMouth.CG(DETECTED_MOUTH_WIDTH * 2 / 3, 0, DETECTED_MOUTH_WIDTH - 1, DETECTED_MOUTH_HEIGHT - 1, 0, 0, 0, point_x, point_y)
'Call imgMouth.setPoint(point_x, point_y, 0, 0)
'Call imgMouth.setPoint(point_x, point_y, 1, 255)
'Call imgMouth.setPoint(point_x, point_y, 2, 0)
mouthOpenPercent = imgMouth.relativeThreshold(20)
'lblMouthOpen.Caption = mouthOpenPercent
'If (mouthOpenPercent > 10) Then
' frmEmoticon.mouthOpen = mouthOpenPercent * 4
' frmEmoticon.displayEmotion (EMOTION_MOUTH_OPEN)
' Else
' frmEmoticon.displayEmotion (EMOTION_MOUTH_NORMAL)
'End If
Call imgMouth.Show(picMouth)
Next
'Call showFace(picFace, leftEyeCorner(0), rightEyeCorner(0), eyeCentre(0), eyesY(0), eyebrow_y(0), rightEyeCorner(1), leftEyeCorner(1), eyeCentre(1), eyesY(1), eyebrow_y(1), 0, mouthOpenPercent)
showObjects_exit:
Exit Sub
showObjects_err:
If (Err = 6) Then
Resume Next
End If
MsgBox "frmMain/showObjects/" & Err & "/" & Error$(Err)
Resume showObjects_exit
End Sub
Private Sub loadSettings()
Dim filename As String
filename = App.Path & "\settings.txt"
If (Dir$(filename) <> "") Then
Open filename For Input As #1
Input #1, Filter_Name
Close #1
End If
End Sub
Private Sub saveSettings()
Dim filename As String
filename = App.Path & "\settings.txt"
Open filename For Output As #1
Print #1, Filter_Name
Close #1
End Sub
Private Sub showFace(pic As PictureBox, leftEyeOuter As Integer, leftEyeInner As Integer, leftEyePupil_x As Integer, leftEyePupil_y As Integer, leftEyebrow_y As Integer, rightEyeOuter As Integer, rightEyeInner As Integer, rightEyePupil_x As Integer, rightEyePupil_y As Integer, rightEyebrow_y As Integer, smile As Integer, mouthOpen As Integer, mouthOpenWidth As Integer)
Dim w As Integer
Dim h As Integer
Dim eyeWidth(3) As Integer
Dim eye_x(2, 3) As Integer
Dim eye_y(2) As Integer
Dim pupil(3) As Integer
Dim eyebrows As Integer
Dim i As Integer
Dim mouthWidth As Integer
Dim mouth_y As Integer
Dim scaleSize(2) As Single
Dim brow(2) As Integer
Dim side_tilt As Integer
Dim lineColour As Long
Dim browRaise As Integer
Static prev_pupil As Integer
Static prev_eyebrows As Integer
Static prev_side_tilt As Integer
pic.Cls
pic.FillColor = RGB(100, 100, 255)
pic.FillStyle = 0
pic.DrawStyle = 0
pic.DrawWidth = 2
lineColour = RGB(0, 0, 0)
w = DETECTED_EYE_WIDTH * 2
h = DETECTED_EYE_HEIGHT * 2
pic.ScaleWidth = w
pic.ScaleHeight = h
eyeWidth(0) = leftEyeInner - leftEyeOuter
eyeWidth(1) = rightEyeOuter - rightEyeInner
eyeWidth(2) = DETECTED_EYE_WIDTH / 2
For i = 0 To 1
scaleSize(i) = eyeWidth(i) / 15#
If (scaleSize(i) < 0.1) Then
scaleSize(i) = 0.1
End If
Next
pupil(0) = ((leftEyePupil_x - leftEyeOuter) * eyeWidth(2)) / eyeWidth(0)
pupil(1) = ((rightEyePupil_x - rightEyeInner) * eyeWidth(2)) / eyeWidth(1)
pupil(2) = ((((pupil(0) + pupil(1)) / 2) * 0.4) + (prev_pupil * 0.6))
prev_pupil = pupil(2)
brow(0) = CInt((leftEyebrow_y - leftEyePupil_y) / scaleSize(0))
brow(1) = CInt((rightEyebrow_y - rightEyePupil_y) / scaleSize(1))
browRaise = (brow(0) + brow(1)) / 2
eyebrows = (DETECTED_EYE_HEIGHT * 3 / 4) + browRaise
eyebrows = (eyebrows + prev_eyebrows) / 2
prev_eyebrows = eyebrows
side_tilt = (leftEyePupil_y + leftEyebrow_y) - (rightEyePupil_y + rightEyebrow_y)
side_tilt = (side_tilt * 0.8) + (prev_side_tilt * 0.2)
prev_side_tilt = side_tilt
lblEyebrows.Caption = side_tilt '(pupil(2) * 100) / eyeWidth(2)
eye_x(0, 0) = DETECTED_EYE_WIDTH / 4
eye_x(0, 1) = eye_x(0, 0) + pupil(2)
eye_x(0, 2) = eye_x(0, 0) + eyeWidth(2)
eye_y(0) = DETECTED_EYE_HEIGHT * 3 / 4
eye_x(1, 0) = DETECTED_EYE_WIDTH + eye_x(0, 0)
eye_x(1, 1) = DETECTED_EYE_WIDTH + eye_x(0, 0) + pupil(2)
eye_x(1, 2) = DETECTED_EYE_WIDTH + eye_x(0, 0) + eyeWidth(2)
eye_y(1) = DETECTED_EYE_HEIGHT * 3 / 4
'eyes
For i = 0 To 1
pic.FillColor = RGB(100, 100, 255)
lineColour = RGB(100, 100, 255)
pic.Circle (eye_x(i, 0) + pupil(2), eye_y(i)), eyeWidth(2) / 4, lineColour ', 0, 6.2, 0.99
pic.FillColor = RGB(0, 0, 0)
lineColour = RGB(0, 0, 0)
pic.Circle (eye_x(i, 0) + pupil(2), eye_y(i)), eyeWidth(2) / 8, lineColour ', 0, 6.2, 0.99
lineColour = RGB(100, 100, 100)
pic.Circle (eye_x(i, 0) + (eyeWidth(2) / 2), eye_y(i)), eyeWidth(2) / 2, lineColour, 0, 6.2, 0.5
Next
'eyebrows
lineColour = RGB(100, 100, 100)
pic.DrawWidth = 4
pic.Circle (eye_x(0, 0) + (eyeWidth(2) / 2), eyebrows), (eye_x(0, 2) - eye_x(0, 0)) * 0.6, lineColour, 0, 3.14, 0.3 + (browRaise / DETECTED_EYE_HEIGHT)
pic.Circle (eye_x(1, 0) + (eyeWidth(2) / 2), eyebrows), (eye_x(1, 2) - eye_x(1, 0)) * 0.6, lineColour, 0, 3.14, 0.3 + (browRaise / DETECTED_EYE_HEIGHT)
'nose
pic.DrawWidth = 1
pic.Circle (DETECTED_EYE_WIDTH, DETECTED_EYE_HEIGHT * 9 / 8), DETECTED_EYE_WIDTH / 8, lineColour, 3.14, 6.2, 0.99
'mouth
lineColour = RGB(200, 0, 0)
pic.DrawWidth = 4
mouthWidth = DETECTED_EYE_WIDTH
mouth_y = DETECTED_EYE_HEIGHT * 13 / 8
If (mouthOpen > 0) Then
pic.Circle (DETECTED_EYE_WIDTH, mouth_y), mouthOpenWidth * 2, lineColour, 0, 3.14, 0# + ((mouthOpen / 100#) * (mouthOpenWidth / 4.5))
pic.Circle (DETECTED_EYE_WIDTH, mouth_y), mouthOpenWidth * 2, lineColour, 3.14, 6.2, 0# + ((mouthOpen / 100#) * 2 * (mouthOpenWidth / 4.5))
Else
mouth_y = mouth_y - (smile / 50)
pic.Circle (DETECTED_EYE_WIDTH, mouth_y), mouthWidth / 2, lineColour, 3.14, 6.2, 0# + ((smile / 500) * 1.5)
pic.Circle (DETECTED_EYE_WIDTH, mouth_y), mouthWidth / 2, lineColour, 3.14, 6.2, 0# + ((smile / 500) * 3)
End If
End Sub