Foros Club Delphi

Foros Club Delphi (https://www.clubdelphi.com/foros/index.php)
-   Varios (https://www.clubdelphi.com/foros/forumdisplay.php?f=11)
-   -   Convertir de VB6 a Delphi7 (https://www.clubdelphi.com/foros/showthread.php?t=51954)

angara 05-01-2008 01:04:39
Convertir de VB6 a Delphi7
 
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 [email protected] 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

Código:

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

Código:

'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

angara 05-01-2008 01:12:54
Destaco que yo uso en mi Delphi7 los componentes MiDAC para base de datos MySQL, en todo caso solo me intereza como convertir el codigo a Delphi7. Gracias

FGarcia 05-01-2008 01:34:47
Hola! solo comentarte que es bueno que el codigo lo envuelvas en las etiquetas delphi 
Código Delphi [-]
 codigo aqui
para una facil lectura del mismo. En la barra de botones del editor de mensajes existe un icono con un aimagen color cafe simulando el partenon griego

Robert01 05-01-2008 15:12:06
Hola

Hay un programa llamado DeLux Converter que hace la conversión de visual basic a delphi entre otos. Pero siempre tendrás que hacer alguna parte en forma manual.

Saludos

angara 05-01-2008 19:48:28
Hola
Gracias por tu respuesta, visite la página recomendada pero el problema es que como es de paga y el demo no genera archivos *.pas no puedo saber si realmente vale la pena adquirirlo ya que es elevado su costo para mi y además de no saber si realmente me sirva.
seguire esperando si alguien del foro sabe como hacerlo sin tener que usar un programa.
aclaro para los demás miembros que el codigo que publico es VB y es para ver si se puede trasladar a Delphi
Gracias

dec 05-01-2008 20:01:03
Hola,

Creo que podrías ponerte con ello y consultar en el foro las dudas que te surgan. La tarea que te traes entre manos: traducir el código que has mostrado a Delphi, es demasiado extensa, en mi opinión, como para "pedirla" en los foros. Ponte con ello, y, si encuentras algún problema, aquí habrá quien pueda y quiera echarte una mano. Pero, de plano "pedir" que te traduzcan el código... tal vez ni sea posible, porque ese código hay que situarlo en su contexto, no es sólo traducirlo, hay que "comprobarlo", por decirlo así. En fin, esta es mi opinión.


La franja horaria es GMT +2. Ahora son las 11:16:58.

Powered by vBulletin® Version 3.6.8
Copyright ©2000 - 2026, Jelsoft Enterprises Ltd.
Traducción al castellano por el equipo de moderadores del Club Delphi