angara
05-01-2008, 01:04:39
Hola nececito realizar un proyecto con identificación de huella, destaco que hice algo modificando un poco un ejemplo, que encontre por ahi, pero es muy lento para la identificacion. Sin embargo en encontre un ejemplo desarrollado en VB6 el cual me paso los fuentes jonas@surinf.com este si realiza la identificación muy rapido, pero yo tengo todo el proyecto realizado en Delphi7 y solo me falta este modulo. por ello solicito la buena voluntad de alguno que me pueda ayudar a convertir este mini utilidad VB6 a Delphi7. puedo publicar el codigo o embiarlo a un mail. Gracias desde ya.
Este es el codigo VB
Formulario
Private Sub AreaGuardar_Change()
ChecaGuardar
End Sub
Private Sub btn_Guardar_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.CursorLocation = adUseClient
conn.ConnectionString = dame_cadena_conexion
conn.Open
rs.Open "Select * from usuarios where 1=0", conn, adOpenStatic, adLockOptimistic 'Set Resultado = BD.OpenRecordset("SELECT * FROM usuarios")
'para usar el recordset con el with tienes que usar .Fields("nombre_campo")
'la otra manera de hacerlo es con rs!nombre_campo
With rs ' Resultado
.AddNew
.Fields("nombre") = NombreGuardar
.Fields("area") = AreaGuardar
.Fields("huella1") = template(1).tpt
.Fields("huella2") = template(2).tpt
.Fields("fecha") = Now
.Update
End With
rs.Close
MsgBox "Huellas guardadas"
Imagen(1).Picture = LoadPicture()
Imagen(2).Picture = LoadPicture()
NombreGuardar = ""
AreaGuardar = ""
Set rs = Nothing
conn.Close
Set conn = Nothing
Imagen_Click 1
End Sub
Private Sub Command1_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.CursorLocation = adUseClient
conn.ConnectionString = dame_cadena_conexion
conn.Open
rs.Open "truncate table usuarios", conn, adOpenStatic, adLockOptimistic 'BD.Execute "DELETE FROM usuarios"
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
conn.Close
Set conn = Nothing
MsgBox "Ok"
End Sub
Private Sub Form_Load()
Dim Error As Integer
'Set BD = OpenDatabase(App.Path & "\bd.mdb")
Timer1.Enabled = True
' Inicializar
Error = Inicializar(Form1)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
'BD.Close
'Set BD = Nothing
End Sub
Private Sub ChecaGuardar()
If Imagen(1) <> 0 And Imagen(2) <> 0 And NombreGuardar <> "" And AreaGuardar <> "" Then
btn_Guardar.Enabled = True
Else
btn_Guardar.Enabled = False
End If
End Sub
Private Sub Imagen_Click(Index As Integer)
ImagenNumero = Index
If Index = 1 Then
Shape1.Left = 250
Else
Shape1.Left = 2530
End If
End Sub
Private Sub GrFingerXCtrl1_ImageAcquired(ByVal idSensor As String, ByVal width As Long, ByVal height As Long, rawImage As Variant, ByVal res As Long)
' Capturar Imagen (Este mensaje es muy raro que se vea. Si se muestra pero muy rapido)
Mensajes = "Capturando imagen..."
With raw
.img = rawImage
.height = height
.width = width
.res = res
End With
If OptionGuardar.Value = True Then
CapturaHuella False, GR_DEFAULT_CONTEXT, Form1, Form1.Imagen(ImagenNumero), ImagenNumero
If EncuentraPuntos(Form1, Mensajes, Imagen(ImagenNumero), ImagenNumero) = True Then
' Aqui entra si la Imagen se detecta bien
If ImagenNumero = 1 Then
Imagen_Click 2
Else
Imagen_Click 1
End If
End If
ChecaGuardar
End If
If OptionVerificar.Value = True Then
CapturaHuella False, GR_DEFAULT_CONTEXT, Form1, Form1.Imagen(3), 3
If EncuentraPuntos(Form1, Mensajes, Imagen(3), 3) = True Then
' El numero 3 es por el Template que es el numero 3
CambiaFoco Identificar(Form1, 3, Form1.NombreVerificar, Form1.AreaVerificar)
End If
End If
End Sub
Private Sub GrFingerXCtrl1_SensorPlug(ByVal idSensor As String)
' Inicializar la Captura del dispositivo
GrFingerXCtrl1.CapStartCapture (idSensor)
End Sub
Private Sub GrFingerXCtrl1_SensorUnplug(ByVal idSensor As String)
' Finalizar la Captura del dispositivo
GrFingerXCtrl1.CapStopCapture (idSensor)
End Sub
Private Sub GrFingerXCtrl1_FingerDown(ByVal idSensor As String)
' Aqui detecta cuando pones el dedo (Este mensaje es muy raro que se vea. Si se muestra pero muy rapido)
Detector = "Huella detectada"
End Sub
Private Sub GrFingerXCtrl1_FingerUp(ByVal idSensor As String)
' Aqui detecta cuando quitas el dedo
Detector = "Huella removida"
End Sub
Private Sub NombreGuardar_Change()
ChecaGuardar
End Sub
Private Sub OptionGuardar_Click()
OcultarFrames
FrameGuardar.Visible = True
End Sub
Private Sub OcultarFrames()
FrameGuardar.Visible = False
FrameVerificar.Visible = False
Detector = ""
Mensajes = ""
Imagen(1).Picture = LoadPicture()
Imagen(2).Picture = LoadPicture()
Imagen(3).Picture = LoadPicture()
Imagen_Click 1
End Sub
Private Sub OptionVerificar_Click()
OcultarFrames
FrameVerificar.Visible = True
End Sub
Private Sub CambiaFoco(Color As Integer)
If Color = 1 Then
Foco.BackColor = &HFF00&
Else
Foco.BackColor = &HFF&
End If
End Sub
Private Sub Timer1_Timer()
Text1.Text = Format(Now, "dd/MM/yyyy hh:mm:ss")
End Sub
Este es el Modulo
'Public BD As Database
'Public Resultado As Recordset
'hay que recordar incluir una referencia a Microsoft ActiveX Data Objects 2.8 Library
'y bajar la última actualización de MDAC (Microsoft Data Access Components) de la web de microsoft
'así como tener instalado el driver ODBC de MYSQL
Public Type rawImage
img As Variant
width As Long
height As Long
res As Long
End Type
Public Type TTemplate
tpt() As Byte
Size As Long
End Type
Public raw As rawImage
Public template(3) As TTemplate
Public Function dame_cadena_conexion() As String
dame_cadena_conexion = "DRIVER={MySQL ODBC 3.51 Driver};" _
& "SERVER=127.0.0.1;" _
& "DATABASE=fingerprints;" _
& "UID=root;" _
& "PWD=12345678;" _
& "OPTION=" & 1 + 2 + 8 + 32 + 2048 + 16384
'En SERVER el nombre o la IP Pública del servidor de datos
'Si usamos la misma máquina sería localhost o 127.0.0.1
'en DATABASE el nombre de la BASE DE DATOS
'en UID el nombre del usuario
'en PWD el password
'hay que dejar las opciones porque suele funcionar mejor
End Function
Public Function Identificar(Formulario As Form, Numero As Integer, Nombre As Label, Area As Label) As Integer
On Error Resume Next
Dim ret As Integer
Dim tpt() As Byte
Dim Cuantos As Integer
Identificar = 0
ret = Formulario.GrFingerXCtrl1.IdentifyPrepare(template(Numero).tpt, GR_DEFAULT_CONTEXT)
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.CursorLocation = adUseClient
conn.ConnectionString = dame_cadena_conexion
conn.Open
rs.Open "Select * from usuarios", conn, adOpenStatic, adLockReadOnly ' Set Resultado = BD.OpenRecordset("SELECT * FROM usuarios")
rs.MoveLast 'Resultado.MoveLast
Cuantos = rs.RecordCount 'Resultado.RecordCount
rs.MoveFirst ' Resultado.MoveFirst
For i = 1 To Cuantos
' Revisar si es la Huella1
tpt = rs!huella1 'Resultado.Fields("huella1")
ret = Formulario.GrFingerXCtrl1.Identify(tpt, 0, GR_DEFAULT_CONTEXT)
If ret = GR_MATCH Then
Nombre = rs!Nombre 'Resultado.Fields("nombre")
Area = rs!Area 'Resultado.Fields("area")
Identificar = 1
Exit Function
Else
' Revisar si es la Huella2
tpt = rs!huella2 'Resultado.Fields("huella2")
ret = Formulario.GrFingerXCtrl1.Identify(tpt, 0, GR_DEFAULT_CONTEXT)
If ret = GR_MATCH Then
Nombre = rs!Nombre 'Resultado.Fields("nombre")
Area = rs!Area 'Resultado.Fields("area")
Identificar = 1
Exit Function
Else
rs.MoveNext 'Resultado.MoveNext
End If
End If
Next i
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
Nombre = ""
Area = ""
End Function
Public Function Inicializar(Formulario As Form) As Integer
Err = Formulario.GrFingerXCtrl1.Initialize
If Err < 0 Then
Inicializar = Err
Exit Function
End If
Inicializar = Formulario.GrFingerXCtrl1.CapInitialize
End Function
Public Sub CapturaHuella(ByVal biometricDisplay As Boolean, ByVal context As Integer, Formulario As Form, LaImagen As Image, Numero As Integer)
Dim handle As IPictureDisp
Dim ret As Integer
If biometricDisplay Then
Formulario.GrFingerXCtrl1.biometricDisplay template(Numero).tpt, raw.img, raw.width, raw.height, raw.res, Formulario.hDC, handle, context
Else
Formulario.GrFingerXCtrl1.CapRawImageToHandle raw.img, raw.width, raw.height, Formulario.hDC, handle
End If
If Not (handle Is Nothing) Then
LaImagen.Picture = handle
End If
End Sub
Public Function EncuentraPuntos(Formulario As Form, ControlMensajes As Label, LaImagen As Image, Numero As Integer) As Boolean
Dim ret As Integer
template(Numero).Size = GR_MAX_SIZE_TEMPLATE
ReDim Preserve template(Numero).tpt(template(Numero).Size)
ret = Formulario.GrFingerXCtrl1.Extract(raw.img, raw.width, raw.height, raw.res, template(Numero).tpt, template(Numero).Size, GR_DEFAULT_CONTEXT)
If ret < 0 Then template(Numero).Size = 0
ReDim Preserve template(Numero).tpt(template(Numero).Size)
If ret = GR_BAD_QUALITY Then
ControlMensajes = "Huella detectada pero con baja calidad. Intentalo nuevamente"
LaImagen.Picture = LoadPicture()
ElseIf ret = GR_MEDIUM_QUALITY Then
ControlMensajes = "Huella detectada con calidad mediana"
ElseIf ret = GR_HIGH_QUALITY Then
ControlMensajes = "Huella detectada con buena calidad"
End If
If ret >= 1 Then
CapturaHuella True, GR_NO_CONTEXT, Formulario, LaImagen, Numero
EncuentraPuntos = True
Else
EncuentraPuntos = False
End If
End Function
* Nota hay que instalar las SDK de Griaule
Este es el codigo VB
Formulario
Private Sub AreaGuardar_Change()
ChecaGuardar
End Sub
Private Sub btn_Guardar_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.CursorLocation = adUseClient
conn.ConnectionString = dame_cadena_conexion
conn.Open
rs.Open "Select * from usuarios where 1=0", conn, adOpenStatic, adLockOptimistic 'Set Resultado = BD.OpenRecordset("SELECT * FROM usuarios")
'para usar el recordset con el with tienes que usar .Fields("nombre_campo")
'la otra manera de hacerlo es con rs!nombre_campo
With rs ' Resultado
.AddNew
.Fields("nombre") = NombreGuardar
.Fields("area") = AreaGuardar
.Fields("huella1") = template(1).tpt
.Fields("huella2") = template(2).tpt
.Fields("fecha") = Now
.Update
End With
rs.Close
MsgBox "Huellas guardadas"
Imagen(1).Picture = LoadPicture()
Imagen(2).Picture = LoadPicture()
NombreGuardar = ""
AreaGuardar = ""
Set rs = Nothing
conn.Close
Set conn = Nothing
Imagen_Click 1
End Sub
Private Sub Command1_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.CursorLocation = adUseClient
conn.ConnectionString = dame_cadena_conexion
conn.Open
rs.Open "truncate table usuarios", conn, adOpenStatic, adLockOptimistic 'BD.Execute "DELETE FROM usuarios"
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
conn.Close
Set conn = Nothing
MsgBox "Ok"
End Sub
Private Sub Form_Load()
Dim Error As Integer
'Set BD = OpenDatabase(App.Path & "\bd.mdb")
Timer1.Enabled = True
' Inicializar
Error = Inicializar(Form1)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
'BD.Close
'Set BD = Nothing
End Sub
Private Sub ChecaGuardar()
If Imagen(1) <> 0 And Imagen(2) <> 0 And NombreGuardar <> "" And AreaGuardar <> "" Then
btn_Guardar.Enabled = True
Else
btn_Guardar.Enabled = False
End If
End Sub
Private Sub Imagen_Click(Index As Integer)
ImagenNumero = Index
If Index = 1 Then
Shape1.Left = 250
Else
Shape1.Left = 2530
End If
End Sub
Private Sub GrFingerXCtrl1_ImageAcquired(ByVal idSensor As String, ByVal width As Long, ByVal height As Long, rawImage As Variant, ByVal res As Long)
' Capturar Imagen (Este mensaje es muy raro que se vea. Si se muestra pero muy rapido)
Mensajes = "Capturando imagen..."
With raw
.img = rawImage
.height = height
.width = width
.res = res
End With
If OptionGuardar.Value = True Then
CapturaHuella False, GR_DEFAULT_CONTEXT, Form1, Form1.Imagen(ImagenNumero), ImagenNumero
If EncuentraPuntos(Form1, Mensajes, Imagen(ImagenNumero), ImagenNumero) = True Then
' Aqui entra si la Imagen se detecta bien
If ImagenNumero = 1 Then
Imagen_Click 2
Else
Imagen_Click 1
End If
End If
ChecaGuardar
End If
If OptionVerificar.Value = True Then
CapturaHuella False, GR_DEFAULT_CONTEXT, Form1, Form1.Imagen(3), 3
If EncuentraPuntos(Form1, Mensajes, Imagen(3), 3) = True Then
' El numero 3 es por el Template que es el numero 3
CambiaFoco Identificar(Form1, 3, Form1.NombreVerificar, Form1.AreaVerificar)
End If
End If
End Sub
Private Sub GrFingerXCtrl1_SensorPlug(ByVal idSensor As String)
' Inicializar la Captura del dispositivo
GrFingerXCtrl1.CapStartCapture (idSensor)
End Sub
Private Sub GrFingerXCtrl1_SensorUnplug(ByVal idSensor As String)
' Finalizar la Captura del dispositivo
GrFingerXCtrl1.CapStopCapture (idSensor)
End Sub
Private Sub GrFingerXCtrl1_FingerDown(ByVal idSensor As String)
' Aqui detecta cuando pones el dedo (Este mensaje es muy raro que se vea. Si se muestra pero muy rapido)
Detector = "Huella detectada"
End Sub
Private Sub GrFingerXCtrl1_FingerUp(ByVal idSensor As String)
' Aqui detecta cuando quitas el dedo
Detector = "Huella removida"
End Sub
Private Sub NombreGuardar_Change()
ChecaGuardar
End Sub
Private Sub OptionGuardar_Click()
OcultarFrames
FrameGuardar.Visible = True
End Sub
Private Sub OcultarFrames()
FrameGuardar.Visible = False
FrameVerificar.Visible = False
Detector = ""
Mensajes = ""
Imagen(1).Picture = LoadPicture()
Imagen(2).Picture = LoadPicture()
Imagen(3).Picture = LoadPicture()
Imagen_Click 1
End Sub
Private Sub OptionVerificar_Click()
OcultarFrames
FrameVerificar.Visible = True
End Sub
Private Sub CambiaFoco(Color As Integer)
If Color = 1 Then
Foco.BackColor = &HFF00&
Else
Foco.BackColor = &HFF&
End If
End Sub
Private Sub Timer1_Timer()
Text1.Text = Format(Now, "dd/MM/yyyy hh:mm:ss")
End Sub
Este es el Modulo
'Public BD As Database
'Public Resultado As Recordset
'hay que recordar incluir una referencia a Microsoft ActiveX Data Objects 2.8 Library
'y bajar la última actualización de MDAC (Microsoft Data Access Components) de la web de microsoft
'así como tener instalado el driver ODBC de MYSQL
Public Type rawImage
img As Variant
width As Long
height As Long
res As Long
End Type
Public Type TTemplate
tpt() As Byte
Size As Long
End Type
Public raw As rawImage
Public template(3) As TTemplate
Public Function dame_cadena_conexion() As String
dame_cadena_conexion = "DRIVER={MySQL ODBC 3.51 Driver};" _
& "SERVER=127.0.0.1;" _
& "DATABASE=fingerprints;" _
& "UID=root;" _
& "PWD=12345678;" _
& "OPTION=" & 1 + 2 + 8 + 32 + 2048 + 16384
'En SERVER el nombre o la IP Pública del servidor de datos
'Si usamos la misma máquina sería localhost o 127.0.0.1
'en DATABASE el nombre de la BASE DE DATOS
'en UID el nombre del usuario
'en PWD el password
'hay que dejar las opciones porque suele funcionar mejor
End Function
Public Function Identificar(Formulario As Form, Numero As Integer, Nombre As Label, Area As Label) As Integer
On Error Resume Next
Dim ret As Integer
Dim tpt() As Byte
Dim Cuantos As Integer
Identificar = 0
ret = Formulario.GrFingerXCtrl1.IdentifyPrepare(template(Numero).tpt, GR_DEFAULT_CONTEXT)
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.CursorLocation = adUseClient
conn.ConnectionString = dame_cadena_conexion
conn.Open
rs.Open "Select * from usuarios", conn, adOpenStatic, adLockReadOnly ' Set Resultado = BD.OpenRecordset("SELECT * FROM usuarios")
rs.MoveLast 'Resultado.MoveLast
Cuantos = rs.RecordCount 'Resultado.RecordCount
rs.MoveFirst ' Resultado.MoveFirst
For i = 1 To Cuantos
' Revisar si es la Huella1
tpt = rs!huella1 'Resultado.Fields("huella1")
ret = Formulario.GrFingerXCtrl1.Identify(tpt, 0, GR_DEFAULT_CONTEXT)
If ret = GR_MATCH Then
Nombre = rs!Nombre 'Resultado.Fields("nombre")
Area = rs!Area 'Resultado.Fields("area")
Identificar = 1
Exit Function
Else
' Revisar si es la Huella2
tpt = rs!huella2 'Resultado.Fields("huella2")
ret = Formulario.GrFingerXCtrl1.Identify(tpt, 0, GR_DEFAULT_CONTEXT)
If ret = GR_MATCH Then
Nombre = rs!Nombre 'Resultado.Fields("nombre")
Area = rs!Area 'Resultado.Fields("area")
Identificar = 1
Exit Function
Else
rs.MoveNext 'Resultado.MoveNext
End If
End If
Next i
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
Nombre = ""
Area = ""
End Function
Public Function Inicializar(Formulario As Form) As Integer
Err = Formulario.GrFingerXCtrl1.Initialize
If Err < 0 Then
Inicializar = Err
Exit Function
End If
Inicializar = Formulario.GrFingerXCtrl1.CapInitialize
End Function
Public Sub CapturaHuella(ByVal biometricDisplay As Boolean, ByVal context As Integer, Formulario As Form, LaImagen As Image, Numero As Integer)
Dim handle As IPictureDisp
Dim ret As Integer
If biometricDisplay Then
Formulario.GrFingerXCtrl1.biometricDisplay template(Numero).tpt, raw.img, raw.width, raw.height, raw.res, Formulario.hDC, handle, context
Else
Formulario.GrFingerXCtrl1.CapRawImageToHandle raw.img, raw.width, raw.height, Formulario.hDC, handle
End If
If Not (handle Is Nothing) Then
LaImagen.Picture = handle
End If
End Sub
Public Function EncuentraPuntos(Formulario As Form, ControlMensajes As Label, LaImagen As Image, Numero As Integer) As Boolean
Dim ret As Integer
template(Numero).Size = GR_MAX_SIZE_TEMPLATE
ReDim Preserve template(Numero).tpt(template(Numero).Size)
ret = Formulario.GrFingerXCtrl1.Extract(raw.img, raw.width, raw.height, raw.res, template(Numero).tpt, template(Numero).Size, GR_DEFAULT_CONTEXT)
If ret < 0 Then template(Numero).Size = 0
ReDim Preserve template(Numero).tpt(template(Numero).Size)
If ret = GR_BAD_QUALITY Then
ControlMensajes = "Huella detectada pero con baja calidad. Intentalo nuevamente"
LaImagen.Picture = LoadPicture()
ElseIf ret = GR_MEDIUM_QUALITY Then
ControlMensajes = "Huella detectada con calidad mediana"
ElseIf ret = GR_HIGH_QUALITY Then
ControlMensajes = "Huella detectada con buena calidad"
End If
If ret >= 1 Then
CapturaHuella True, GR_NO_CONTEXT, Formulario, LaImagen, Numero
EncuentraPuntos = True
Else
EncuentraPuntos = False
End If
End Function
* Nota hay que instalar las SDK de Griaule