Visual Basic - Codigo

Life is soft - evento anual de software empresarial
   
Vista:

Codigo

Publicado por Car (3 intervenciones) el 31/08/2007 17:30:02
Hola buen dia:
Mi situación es la siguiente; tengo una base de datos en la cual tengo unicamente una tabla y un formulario, la idea original era que por medio del formulario pasara registro por registro, y, eso ya esta, pero ahora quisiera saber si alguien me puede ayudar ya que posicionandome en la imagen de cada resgistro al momento de visualizar regsitro a registro dando doble click me mande a imprimir la imagen del registro activo, por favor si alguien pudiera ayudarme se los aradezco profundamente.

Gracias y que pasen buena tarde el codigo que tengo es el siguiente:

Option Compare Database
Option Explicit

Private Declare Function AbrirArchivo Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As NOMBREARCHIVO) As Long

Private Type NOMBREARCHIVO
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Sub cmdAbrir_Click()
On Error GoTo cmdAbrir_Click_TratamientoErrores

Dim strArchivo As NOMBREARCHIVO

strArchivo.lStructSize = Len(strArchivo)
strArchivo.hwndOwner = Me.Hwnd
strArchivo.lpstrFilter = "Imagenes (*.bmp, *.png, *.gif, *.tif, *.jpg)" + Chr$(0) + "*.bmp;*.png; *.gif; *.tif; *.jpg" + Chr$(0) + "Todos los archivos (*.*)" + Chr$(0) + "*.*" + Chr$(0)
strArchivo.lpstrFile = Space$(254)
strArchivo.nMaxFile = 255
strArchivo.lpstrFileTitle = Space$(254)
strArchivo.nMaxFileTitle = 255
strArchivo.lpstrInitialDir = "C:\"
strArchivo.lpstrTitle = "Seleccionar Imagen"
strArchivo.flags = 0

If AbrirArchivo(strArchivo) Then
txtRuta = Trim$(strArchivo.lpstrFile)
txtRuta_AfterUpdate
Else
txtRuta = ""
End If

cmdAbrir_Click_Salir:
On Error GoTo 0
Exit Sub

cmdAbrir_Click_TratamientoErrores:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en proc. cmdAbrir_Click de Documento VBA Form_frmImagenes"
GoTo cmdAbrir_Click_Salir

End Sub

Private Sub Form_Current()
On Error GoTo Form_Current_TratamientoErrores

If Not IsNull(txtRuta) Then
MuestraImagen (txtRuta)
Else
Imagen.Picture = ""
End If

Form_Current_Salir:
On Error GoTo 0
Exit Sub

Form_Current_TratamientoErrores:

Call MsgBox("Error " & Err.Number & " (" & Err.Description & ") en proc. Form_Current de Documento VBA Form_frmImagenes")
GoTo Form_Current_Salir
End Sub

Public Sub MuestraImagen(strRuta As String)

On Error GoTo MuestraImagen_TratamientoErrores

If Dir(strRuta) Then
Imagen.Picture = strRuta
Else
Err.Raise 2220
End If

MuestraImagen_Salir:
On Error GoTo 0
Exit Sub

MuestraImagen_TratamientoErrores:
Select Case Err.Number
Case 2220
Call MsgBox("La imagen no existe, comprueba que el nombre del archivo es correcto", vbExclamation Or vbSystemModal, "ATENCION")
Case 2114
Call MsgBox("El formato de el archivo no se corresponde con una imagen, comprueba que el nombre del archivo es correcto", vbExclamation Or vbSystemModal, "ATENCION")
Case 2244
Call MsgBox("El archivo está vacío, comprueba que el nombre del archivo es correcto", vbExclamation Or vbSystemModal, "ATENCION")
Case Else
Call MsgBox("Error " & Err.Number & " (" & Err.Description & ") en proc. MuestraImagen de Documento VBA Form_frmImagenes")
End Select

GoTo MuestraImagen_Salir
End Sub

Private Sub txtRuta_AfterUpdate()
On Error GoTo txtRuta_AfterUpdate_TratamientoErrores

If Not IsNull(txtRuta) Then
MuestraImagen (txtRuta)
Else
Imagen.Picture = ""
End If

txtRuta_AfterUpdate_Salir:
On Error GoTo 0
Exit Sub

txtRuta_AfterUpdate_TratamientoErrores:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en proc. txtRuta_AfterUpdate de Documento VBA Form_frmImagenes"
GoTo txtRuta_AfterUpdate_Salir

End Sub

Public Function Dir(strArchivo) As Boolean
Dim fso As Object, _
f As Object

On Error GoTo Dir_TratamientoErrores

On Error GoTo Dir_TratamientoErrores

Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.GetFile(strArchivo)

If Len(f.Path) = "" Then
Dir = False
Else
Dir = True
End If

Set fso = Nothing
Set f = Nothing

Dir_Salir:
On Error GoTo 0
Exit Function

Dir_TratamientoErrores:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en proc. Dir de Documento VBA Form_frmImagenes"
GoTo Dir_Salir

End Function
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder