Visual Basic – Aplicación para escanear version 1.0.0

Visual Basic – Aplicación para escanear version 1.0.0

DEFINICION:
Qué hace?
Al dar de alta un usuario se debe llenar un campo obligatorio que es el número de pasaporte. Seguidamente con este numero se crea una pequeña galeria con las paginas que se van escaneando del pasaporte en cuestion.
Los datos del usuario y de sus imágenes escaneadas se guardan en una Base de datos de MS Access.
ESPECIFICACION:
Cómo lo hace?
La aplicacion utiliza unos controles ocx especiales que venian en Windows 98 y 2000. (Imaging). Una vez guardado el usuario en la BD se deja a modo temporal su nº de pasaporte. Con el control image manager se gestiona el resto de controles y se guarda en el disco la imagen escaneada aplicando al nombre el número.
Descarga el código fuente aqui.
Imagenes:

Nota:  Si deseas ver la programación (codigo fuente) lo puedes hacer en las últimas páginas.

Código fuente de: frmClientes.frm Option Explicit 'Mi objeto de conexion Public oConx As ADODB.Connection 'Mi objeto tabla con conexion persistente Public WithEvents oRsCliente As ADODB.Recordset 'Las imagenes y el id de los clientes tendran el formato CLIxxx siendo xxx un entero Private Const sCPrefijo As String = "CLI" Dim sRutaFoto As String Dim sExiste As String Dim sNombreArchivo As String Dim dFechaDemo As Date Dim vAuxiliar As Variant Dim iTotalRegistros, i, j, iZoom As Long 'Lee la variable globla sNombreArchivo, con esta crea la sRutaArchivo completa 'e intenta recuperarla. Si lo consigue la muestra sino desactiva los controles Private Sub cargar_imagen() On Error GoTo isError: 'activo la barra horizontal de zoom hsbZoom.Enabled = True 'Creo la sRutaArchivo completa hasta la foto sRutaFoto = CStr(App.Path &amp; "\fotos\\" &amp; sNombreArchivo &amp; ".jpg") 'Intento obtener el nombre de la foto sExiste = Dir(sRutaFoto) 'devuelve nomarchivo.jpg si existe en sRutaFoto iZoom = 33 If sExiste = "" Then 'si no existe la imagen 'imePantalla es el control imageEdit que se usa para ir mostrando las imagenes 'segun se posiciona en el cliente imePantalla.Visible = False 'Escondemos la pantalla hsbZoom.Enabled = False 'Escondemos la barra de zoom Else 'si existe la imagen imePantalla.Visible = True lblValorZoom.Caption = iZoom imePantalla.Image = sRutaFoto imePantalla.Display imePantalla.Zoom = iZoom imePantalla.Refresh End If Exit Sub isError: MsgBox "Ocurrio error al cargar imagen", vbCritical, "Clientes UC" End Sub Public Function Buscar(oRecordSet As ADODB.Recordset, sIdCliente As String) oRecordSet.MoveFirst If oRecordSet.EOF Then oRecordSet.MoveFirst End If While Not oRecordSet("IDCLI") = sIdCliente oRecordSet.MoveNext Wend 'Actualizo la posicion del puntero en el txt txtRegActual.Text = oRecordSet.AbsolutePosition 'Actualizo la variable global sNombreArchivo con el id sNombreArchivo = sIdCliente 'Intenta cargar la imagen en el control imePantalla cargar_imagen End Function Public Function Primero(oRecordSet As ADODB.Recordset, txtRegActual As TextBox) If oRecordSet.RecordCount = 0 Then MsgBox "NO HAY REGISTROS PARA HACER RECORRIDO", vbExclamation, _ "INFORMACION DE RECORRIDO" txtRegActual.Text = 0 ElseIf oRecordSet.RecordCount > 0 Then If oRecordSet.AbsolutePosition = 1 Then MsgBox "YA ESTA EN EL PRIMER REGISTRO", vbExclamation, _ "INFORMACION DE RECORRIDO" End If oRecordSet.MoveFirst txtRegActual.Text = oRecordSet.AbsolutePosition End If End Function Public Function Ultimo(oRecordSet As ADODB.Recordset, txtRegActual As TextBox) If oRecordSet.RecordCount = 0 Then MsgBox "NO HAY REGISTROS PARA HACER RECORRIDO", vbExclamation, _ "INFORMACION DE RECORRIDO" txtRegActual.Text = 0 ElseIf oRecordSet.RecordCount > 0 Then If oRecordSet.AbsolutePosition = oRecordSet.RecordCount Then MsgBox "YA ESTA EN EL ULTIMO REGISTRO", vbExclamation, _ "INFORMACION DE RECORRIDO" End If oRecordSet.MoveLast txtRegActual.Text = oRecordSet.AbsolutePosition End If End Function Public Function Siguiente(oRecordSet As ADODB.Recordset, txtRegActual As TextBox) If oRecordSet.RecordCount > 0 Then oRecordSet.MoveNext If oRecordSet.EOF Then MsgBox "YA ESTA EN EL ULTIMO REGISTRO", vbExclamation, _ "INFORMACION DE RECORRIDO" oRecordSet.MoveLast End If txtRegActual.Text = oRecordSet.AbsolutePosition ElseIf oRecordSet.RecordCount = 0 Then txtRegActual.Text = 0 End If End Function Public Function Anterior(oRecordSet As ADODB.Recordset, txtRegActual As TextBox) If oRecordSet.RecordCount > 0 Then oRecordSet.MovePrevious If oRecordSet.BOF Then MsgBox "YA ESTA EN EL PRIMER REGISTRO", vbExclamation, _ "INFORMACION DE RECORRIDO" oRecordSet.MoveFirst End If txtRegActual.Text = oRecordSet.AbsolutePosition ElseIf oRecordSet.RecordCount = 0 Then txtRegActual.Text = 0 End If End Function Private Sub cmdAceptar_Click() If txtNombre.Text = "" Then MsgBox "This field can't be empty", vbExclamation, "EMPTY FIELD!!" txtNombre.SetFocus GoTo isError End If If txtApellidos.Text = "" Then MsgBox "This field can't be empty", vbExclamation, "EMPTY FIELD!!" txtApellidos.SetFocus GoTo isError End If If txtNPasaporte.Text = "" Then MsgBox "This field can't be empty", vbExclamation, "EMPTY FIELD!!" txtNPasaporte.SetFocus GoTo isError End If Select Case lblAC.Caption Case "AGREGAR" MsgBox "Usuario Añadido", vbInformation + vbOKOnly, "AGREGAR" fraRec.Visible = True txtRegActual.Text = oRsCliente.AbsolutePosition txtTotalRegistros.Text = oRsCliente.RecordCount oRsCliente.Update Case "MODIFICAR" MsgBox "Usuario Modificado", vbInformation + vbOKOnly, "MODIFICAR" fraRec.Visible = True oRsCliente.Update Case Else End Select 'se pasa todo como si se estuviera recorriendo lblAC.Visible = False fraAC.Visible = False fraOpc.Visible = True txtNombre.Enabled = False txtApellidos.Enabled = False txtNPasaporte.Enabled = False isError: End Sub Private Sub cmdAgregar_Click() 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx iTotalRegistros = oRsCliente.RecordCount If iTotalRegistros = 0 Then i = 1 Else ReDim matid(1 To iTotalRegistros) As Long oRsCliente.MoveFirst For i = 1 To iTotalRegistros matid(i) = CLng(Replace(oRsCliente.Fields(0), sCPrefijo, "")) oRsCliente.MoveNext Next For i = 1 To iTotalRegistros For j = 1 To iTotalRegistros If i = matid(j) Then 'i no disponible porque esta en el arreglo Exit For End If Next If j - 1 = iTotalRegistros And i <> matid(iTotalRegistros) Then 'si i!= hasta del ultimo elemento (j=tregs) 'i disponible Exit For End If Next End If 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 'por defecto se hace esto con AGREGAR,MODIFICAR,baja .. fraOpc.Visible = False fraRec.Visible = False fraAC.Visible = True lblAC.Visible = True lblAC.BackColor = &amp;H0&amp; lblAC.ForeColor = &amp;HFFFFFF lblAC.Caption = "AGREGAR" Caption = "USUARIOS [AGREGAR]" '...hasta aqui 'activamos campos txtNombre.Enabled = True txtApellidos.Enabled = True txtNPasaporte.Enabled = True cmdDigitalizar.Visible = True 'Preparamos la tabla para agregar un registro oRsCliente.AddNew txtIdCliente.Text = "" txtNombre.Text = "" txtApellidos.Text = "" txtNPasaporte.Text = "" imePantalla.Visible = False txtIdCliente.Text = UCase(Trim(sCPrefijo) &amp; Trim(Str(i))) 'getID(sCPrefijo, oRsCliente) txtNombre.SetFocus End Sub Private Sub cmdEliminar_Click() If oRsCliente.RecordCount > 1 Then Dim resp As Integer resp = MsgBox("¿Eliminar Cliente?", vbExclamation + vbOKCancel, "BAJA") If resp = 1 Then oRsCliente.Delete oRsCliente.Update txtTotalRegistros.Text = oRsCliente.RecordCount sExiste = Dir(sRutaFoto) If sExiste = "blanco.jpg" Then ElseIf sExiste <> "" Then Kill (sRutaFoto) End If End If cmdAnterior_Click If frmBuscar.isCargado Then frmBuscar.cmdAceptar_Click End If End If End Sub Private Sub cmdBuscar_Click() frmBuscar.Show End Sub Private Sub cmdCancelar_Click() Select Case lblAC.Caption Case "AGREGAR" oRsCliente.CancelUpdate 'MsgBox "No se añadio Usuario", vbInformation + vbOKOnly, "AGREGAR" Case "MODIFICAR" oRsCliente.CancelUpdate 'AQUI DEBERIA VERSE LO NO MODIFICADO 'MsgBox "No se edito Usuario", vbInformation + vbOKOnly, "MODIFICAR" Case Else End Select 'se pasa todo como si se estuviera recorriendo lblAC.Visible = False fraRec.Visible = True fraAC.Visible = False fraOpc.Visible = True txtNombre.Enabled = False txtApellidos.Enabled = False txtNPasaporte.Enabled = False If oRsCliente.RecordCount = 0 Then ElseIf oRsCliente.RecordCount = 1 Then oRsCliente.MoveFirst ElseIf oRsCliente.RecordCount > 1 Then oRsCliente.MoveLast End If End Sub Private Sub cmdEditar_Click() 'por defecto se hace esto con AGREGAR,MODIFICAR,baja .. fraOpc.Visible = False fraRec.Visible = False fraAC.Visible = True lblAC.Visible = True lblAC.BackColor = &amp;H0&amp; lblAC.ForeColor = &amp;HFFFFFF lblAC.Caption = "MODIFICAR" Caption = "USUARIOS [EDITANDO]" '...hasta aqui 'se activan los campos para poder modificarlos txtNombre.Enabled = True txtApellidos.Enabled = True txtNPasaporte.Enabled = True End Sub Private Sub cmdDigitalizar_Click() frmEscanear.cmdObtenerImagen_Click frmEscanear.Show vbModal End Sub Private Sub cmdTab_Click() End Sub 'Al llamar al panel de control Private Sub Form_Initialize() On Error GoTo isError: 'Intento crear la carpeta Fotos si no sExiste MkDir (App.Path &amp; "\\" &amp; "Fotos") FileCopy App.Path &amp; "\blanco.jpg", App.Path &amp; "\Fotos\blanco.jpg" Kill (App.Path &amp; "\blanco.jpg") Exit Sub isError: 'MsgBox "err" End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyF1 Then cmdBuscar_Click KeyAscii = 0 ElseIf KeyAscii = vbKeyF2 Then cmdDigitalizar_Click KeyAscii = 0 End If End Sub Private Sub Form_Load() ' dFechaDemo = Date ' If (dFechaDemo >= #12/15/2005#) Then ' MsgBox "TIME FOR DEMO IS UP!!, FOR INFO:eacevedof@yahoo.es", vbOKOnly + vbExclamation, "PROGRAMA DEMO" ' Unload Me ' Exit Sub ' End If 'Creo mi objeto Conexion y lo configuro Set oConx = New ADODB.Connection oConx.Provider = "Microsoft.jet.oledb.4.0" oConx.CursorLocation = adUseClient oConx.ConnectionString = App.Path &amp; "\uc.mdb" oConx.Open 'Creo mi objeto Recorset sobre la tabla que voy a trabajar Set oRsCliente = New ADODB.Recordset oRsCliente.ActiveConnection = oConx 'conexion que utilizara oRsCliente.Source = "CLIENTES" 'Nombre de la tabla oRsCliente.CursorType = adOpenDynamic 'Como se movera el puntero oRsCliente.LockType = adLockOptimistic 'La recurrencia es de tipo optimista oRsCliente.Open 'Recupero los datos 'Bindeo mis controles con los campos que le corresponden 'El bindeo tiene un efecto de lectura y escritura en tiempo real 'dependiendo de sobre que registro esta el cursor (absolutepostion) Set txtIdCliente.DataSource = oRsCliente 'La fuente de datos (la tabla) txtIdCliente.DataField = "IDCLI" 'El nombre del campo en la tabla Set txtNombre.DataSource = oRsCliente txtNombre.DataField = "NOMBRE" Set txtApellidos.DataSource = oRsCliente txtApellidos.DataField = "APELLIDO" Set txtNPasaporte.DataSource = oRsCliente txtNPasaporte.DataField = "N_PASAPORTE" If oRsCliente.RecordCount = 0 Then txtRegActual.Text = 0 Else txtRegActual.Text = oRsCliente.AbsolutePosition End If 'Configuro la posicion de mi formulario Top = 650 Left = 2100 txtTotalRegistros.Text = oRsCliente.RecordCount sNombreArchivo = txtIdCliente.Text cargar_imagen hsbZoom.Value = iZoom End Sub Private Sub cmdAnterior_Click() On Error GoTo isError: 'llama a la funcion para moverse al anterior registro vAuxiliar = Anterior(oRsCliente, txtRegActual) txtTotalRegistros.Text = oRsCliente.RecordCount cargar_imagen hsbZoom.Value = iZoom Exit Sub isError: sNombreArchivo = oRsCliente("IDCLI") End Sub Private Sub cmdPrimero_Click() On Error GoTo isError: vAuxiliar = Primero(oRsCliente, txtRegActual) sNombreArchivo = oRsCliente("IDCLI") txtTotalRegistros.Text = oRsCliente.RecordCount cargar_imagen hsbZoom.Value = iZoom Exit Sub isError: End Sub Private Sub cmdSiguiente_Click() On Error GoTo isError: vAuxiliar = Siguiente(oRsCliente, txtRegActual) sNombreArchivo = oRsCliente("IDCLI") txtTotalRegistros.Text = oRsCliente.RecordCount cargar_imagen hsbZoom.Value = iZoom Exit Sub isError: End Sub Private Sub cmdUltimo_Click() On Error GoTo isError: vAuxiliar = Ultimo(oRsCliente, txtRegActual) sNombreArchivo = oRsCliente("IDCLI") txtTotalRegistros.Text = oRsCliente.RecordCount cargar_imagen hsbZoom.Value = iZoom Exit Sub isError: End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If frmEscanear.isCargado Then Unload frmEscanear End If If frmBuscar.isCargado Then Unload frmBuscar End If Set oRsCliente = Nothing Set oConx = Nothing End Sub Private Sub Form_Unload(Cancel As Integer) 'Descargo todos mis formularios Set frmClientes = Nothing Set frmEscanear = Nothing Set frmBuscar = Nothing End Sub 'Al desplazar la barra de zoom Private Sub hsbZoom_Change() On Error GoTo isError: 'Actualizo el label con el zoom lblValorZoom.Caption = hsbZoom.Value 'Le aplico el zoom al control imageEdit imePantalla.Zoom = hsbZoom.Value 'Refresco la vista imePantalla.Refresh Exit Sub isError: End Sub Private Sub Label1_Click() End Sub Private Sub txtRegActual_GotFocus() cmdSiguiente.SetFocus End Sub Private Sub txtApellidos_LostFocus() txtApellidos.Text = Trim(txtApellidos.Text) txtApellidos.Text = UCase(txtApellidos.Text) End Sub Private Sub txtNombre_LostFocus() txtNombre.Text = Trim(txtNombre.Text) txtNombre.Text = UCase(txtNombre.Text) End Sub Private Sub txtNPasaporte_LostFocus() txtNPasaporte.Text = Trim(txtNPasaporte.Text) txtNPasaporte.Text = UCase(txtNPasaporte.Text) End Sub Private Sub txtTotalRegistros_GotFocus() cmdSiguiente.SetFocus End Sub Código fuente de: frmEscanear.frm Option Explicit Dim sNombreArchivo As String Public isCargado As Boolean Public sExiste As String Public sCalidadImagen As String Public sRutaArchivo As String Private Sub cmdSalir_Click() On Error GoTo isError 'Activo los controles el formulario de clientes frmClientes.imePantalla.Visible = True frmClientes.imePantalla.Image = txtDestino.Text frmClientes.imePantalla.Zoom = 33 frmClientes.imePantalla.Display 'Descargo este formulario (Escanear) Unload Me isError: Unload Me End Sub Public Sub cmdGuardar_Click() On Error GoTo isError: sRutaArchivo = App.Path &amp; "\FOTOS\" &amp; sNombreArchivo imePrevisualizar.Refresh ' imaSca.InitDir = App.Path &amp; "\FOTOS" ' imaSca.DialogTitle = "Guardar como bmp" ' imaSca.Filter = "BMP files|*.bmp|" ' imaSca.Image = sNombreArchivo ' imaSca.ShowFileDialog SaveDlg ' imePrevisualizar.SaveAs imaSca.Image &amp; ".bmp", 3 'error al cancelar 'Guardo la imagen como bmp que es el formato que permite el control 'imageEdit imePrevisualizar.SaveAs sRutaArchivo &amp; ".bmp", 3 'Guardo las rutas de origen y destino en los txt txtOrigen.Text = sRutaArchivo &amp; ".bmp" txtDestino.Text = sRutaArchivo &amp; ".jpg" 'configuro la compresion del archivo .jpg sCalidadImagen = "75" 'Con el control picformat transformo de bmp a jpg 'tienen q ser objetos txt.text sino no funciona picformat PicFormat321.SaveBmpToJpeg txtOrigen.Text, txtDestino.Text, sCalidadImagen 'Compruebo que existe el .bmp sExiste = Dir(txtOrigen.Text) 'Si existe lo elimino If sExiste <> "" Then Kill (txtOrigen.Text) End If 'activo los controles de frmClientes 'descargo este formulario cmdSalir_Click Exit Sub isError: MsgBox "Ocurrio error al guardar imagen", vbCritical, "Clientes UC" imsControlador.CloseScanner End Sub Public Sub cmdObtenerImagen_Click() On Error GoTo isError: If Not imsControlador.ScannerAvailable Then MsgBox "No hay escáner disponible", vbCritical, "Interface de Escáner" Exit Sub End If 'control imgScan: es un intermediario entre el controlador 'del scanner y los controles de la aplicacion imsControlador.OpenScanner imsControlador.FileType = BMP_Bitmap imsControlador.ScanTo = DisplayOnly imsControlador.StartScan imePrevisualizar.Zoom = 45 imsControlador.CloseScanner Exit Sub isError: imsControlador.StopScan imsControlador.CloseScanner End Sub Private Sub Form_Load() 'Indico que este formulario esta cargado isCargado = True Top = 650 Left = 2000 sNombreArchivo = frmClientes.txtIdCliente.Text imePrevisualizar.DisplayBlankImage 4850, 3450 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 'Indico que este formulario esta descargado isCargado = False End Sub Private Sub Form_Unload(Cancel As Integer) imsControlador.CloseScanner Set frmEscanear = Nothing End Sub Código fuente de: frmBuscar.frm Option Explicit Public WithEvents oRsBuscar As ADODB.Recordset Dim oCommand As ADODB.Command 'Objeto que nos permitira la ejecucion de sentencias SQL Dim sSQL, sIdCliente As String Public isCargado As Boolean 'Para detectar si este formulario está cargado Dim vAuxiliar As Variant Public Sub cmdAceptar_Click() If txtNombre.Text <> "" And txtApellidos.Text <> "" Then sSQL = "SELECT nombre AS NOMBRE, apellido AS APELLIDO, idcli AS IDCLIENTE,n_pasaporte AS NoPASAPORTE FROM clientes" &amp; _ " WHERE nombre LIKE " &amp; "'" &amp; txtNombre.Text &amp; "%" &amp; "'" _ &amp; " AND " &amp; _ "apellido LIKE " &amp; "'" &amp; txtApellidos.Text &amp; "%" &amp; "'" _ &amp; " ORDER BY nombre,apellido" ElseIf txtNombre.Text = "" And txtApellidos.Text <> "" Then sSQL = "SELECT nombre AS NOMBRE,apellido AS APELLIDO,idcli AS IDCLIENTE,n_pasaporte AS NoPASAPORTE FROM clientes" &amp; _ " WHERE apellido LIKE " &amp; "'" &amp; txtApellidos.Text &amp; "%" &amp; "'" _ &amp; " ORDER BY apellido" ElseIf txtNombre.Text <> "" And txtApellidos.Text = "" Then sSQL = "SELECT nombre AS NOMBRE,apellido AS APELLIDO,idcli AS IDCLIENTE,n_pasaporte AS NoPASAPORTE FROM clientes" &amp; _ " WHERE nombre LIKE " &amp; "'" &amp; txtNombre.Text &amp; "%" &amp; "'" _ &amp; " ORDER BY nombre" Else sSQL = "SELECT nombre AS NOMBRE,apellido AS APELLIDO,idcli AS IDCLIENTE,n_pasaporte AS NoPASAPORTE FROM clientes" &amp; _ " ORDER BY nombre" End If oCommand.CommandText = sSQL Set oRsBuscar = oCommand.Execute Set dtgBusqueda.DataSource = oRsBuscar dtgBusqueda.Refresh End Sub Private Sub cmdAceptar_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyEscape Then cmdCancelar_Click KeyAscii = 0 End If End Sub Private Sub cmdCancelar_Click() Set oRsBuscar = Nothing Set dtgBusqueda.DataSource = oRsBuscar dtgBusqueda.Refresh txtNombre.Text = "" txtApellidos.Text = "" txtNombre.SetFocus End Sub Private Sub dtgBusqueda_DblClick() On Error GoTo isError sIdCliente = dtgBusqueda.Columns(2).CellValue(dtgBusqueda.Bookmark) vAuxiliar = frmClientes.Buscar(frmClientes.oRsCliente, sIdCliente) frmClientes.SetFocus frmClientes.Refresh Exit Sub isError: End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyEscape Then cmdCancelar_Click KeyAscii = 0 End If End Sub Private Sub Form_Load() isCargado = True Top = 2000 Left = 2500 Set oRsBuscar = New ADODB.Recordset oRsBuscar.ActiveConnection = frmClientes.oConx Set oCommand = New ADODB.Command oCommand.ActiveConnection = frmClientes.oConx End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) isCargado = False End Sub Private Sub Form_Unload(Cancel As Integer) Set frmBuscar = Nothing End Sub Private Sub txtApellidos_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then cmdAceptar.SetFocus KeyAscii = 0 ElseIf KeyAscii = vbKeyEscape Then cmdCancelar_Click KeyAscii = 0 End If End Sub Private Sub txtNombre_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then txtApellidos.SetFocus KeyAscii = 0 ElseIf KeyAscii = vbKeyEscape Then cmdCancelar_Click KeyAscii = 0 End If End Sub Private Sub txtNombre_LostFocus() txtNombre.Text = UCase(txtNombre.Text) End Sub Private Sub txtApellidos_LostFocus() txtApellidos.Text = UCase(txtApellidos.Text) End Sub

Autor: Eduardo A. F.
Publicado: 16-11-2010 21:09
Actualizado: 10-06-2012 17:19