Envio un codigo
Publicado por Carmen (11 intervenciones) el 21/08/2007 19:08:05
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 lo realice 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
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 lo realice 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


0