insertar imagen en access
Publicado por mary (2 intervenciones) el 06/11/2005 19:02:48
tengo una aplicacion en access y necesito saber como puedo insertar una imagen sea vinculada o incrustada. Tengo un boton para abrir una ventana para elegir la foto, pero el codigo para el boton no me funciona.
si alguien me pudiera ayudar, se lo agradeceria mucho.
gracias.
Este es el generador de codigo.
miradlo y decirme algo, porfavor.
Option Compare Database
Private Sub btnPrimer_Click()
On Error GoTo Err_btnPrimer_Click
DoCmd.GoToRecord , , acFirst
Exit_btnPrimer_Click:
Exit Sub
Err_btnPrimer_Click:
MsgBox Err.Description
Resume Exit_btnPrimer_Click
End Sub
Private Sub btnAnterior_Click()
On Error GoTo Err_btnAnterior_Click
DoCmd.GoToRecord , , acPrevious
Exit_btnAnterior_Click:
Exit Sub
Err_btnAnterior_Click:
MsgBox Err.Description
Resume Exit_btnAnterior_Click
End Sub
Private Sub btnSeguent_Click()
On Error GoTo Err_btnSeguent_Click
DoCmd.GoToRecord , , acNext
Exit_btnSeguent_Click:
Exit Sub
Err_btnSeguent_Click:
MsgBox Err.Description
Resume Exit_btnSeguent_Click
End Sub
Private Sub btnUltim_Click()
On Error GoTo Err_btnUltim_Click
DoCmd.GoToRecord , , acLast
Exit_btnUltim_Click:
Exit Sub
Err_btnUltim_Click:
MsgBox Err.Description
Resume Exit_btnUltim_Click
End Sub
Private Sub btnBuscar_Click()
On Error GoTo Err_btnBuscar_Click
Screen.PreviousControl.SetFocus
DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
Exit_btnBuscar_Click:
Exit Sub
Err_btnBuscar_Click:
MsgBox Err.Description
Resume Exit_btnBuscar_Click
End Sub
Private Sub btnBusSeg_Click()
On Error GoTo Err_btnBusSeg_Click
Screen.PreviousControl.SetFocus
DoCmd.FindNext
Exit_btnBusSeg_Click:
Exit Sub
Err_btnBusSeg_Click:
MsgBox Err.Description
Resume Exit_btnBusSeg_Click
End Sub
Private Sub btnNou_Click()
On Error GoTo Err_btnNou_Click
DoCmd.GoToRecord , , acNewRec
Exit_btnNou_Click:
Exit Sub
Err_btnNou_Click:
MsgBox Err.Description
Resume Exit_btnNou_Click
End Sub
Private Sub btnBorrar_Click()
On Error GoTo Err_btnBorrar_Click
DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
Exit_btnBorrar_Click:
Exit Sub
Err_btnBorrar_Click:
MsgBox Err.Description
Resume Exit_btnBorrar_Click
End Sub
'abrir
Private Sub Comando112_Click()
On Error GoTo Comando112_Click_TratamientoErrores
Dim fd As FileDialog, _
strArchivo As String, _
vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogFilePicker)
' habilito la vista previa de la imagen
fd.InitialView = msoFileDialogViewPreview
' añado al filtro nº 2 algunos formatos de gráfico (el 1 y predeterminado es: todos los archivos)
fd.Filters.Add "Imagenes", "*.bmp; *.gif; *.jpg; *.jpeg; *.png; *.tif", 1
fd.Filters.Add "Todos los archivos", "*.*", 2
' establezco como filtro predetermiando el nº1
fd.FilterIndex = 1
' abro el cuadro de dialogo
If fd.Show = -1 Then
For Each vrtSelectedItem In fd.SelectedItems
strArchivo = CStr(vrtSelectedItem)
Next vrtSelectedItem
End If
Set fd = Nothing
' refresco la imagen
txtRuta = strArchivo
MuestraImagen (strArchivo)
Comando112_Click_Salir:
On Error GoTo 0
Exit Sub
Comando112_Click_TratamientoErrores:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en proc. Comando112_Click de Documento VBA Form_perro"
GoTo Comando112_Click_Salir
End Sub
'*******************************************************************************
'* Form_Current
'* Rutina Al Activar Registro que muestra la imagen correspondiente al registro actual
'* ESH 02/11/03 10:45
'*******************************************************************************
Private Sub Form_Current()
On Error GoTo Form_Current_TratamientoErrores
If Not IsNull(txtRuta) Then
MuestraImagen (txtRuta)
Else
Image.Picture = ""
End If
Form_Current_Salir:
On Error GoTo 0
Exit Sub
Form_Current_TratamientoErrores:
Image.Picture = ""
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en proc. Form_Current de Documento VBA Form_perro"
GoTo Form_Current_Salir
End Sub ' Form_Current
'*******************************************************************************
'* MuestraImagen
'* Muestra la imagen pasada como argumento
'* Argumentos: strRuta => Ruta del archivo imagen a mostrar
'* uso: MuestraImagen (Ruta)
'* ESH 02/11/03 10:43
'*******************************************************************************
Public Sub MuestraImagen(strRuta As String)
On Error GoTo MuestraImagen_TratamientoErrores
If Dir(strRuta) Then
Image.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_perro")
End Select
GoTo MuestraImagen_Salir
End Sub ' MuestraImagen
Private Sub Comando29_Click()
On Error GoTo Err_Comando29_Click
DoCmd.Close
Exit_Comando29_Click:
Exit Sub
Err_Comando29_Click:
MsgBox Err.Description
Resume Exit_Comando29_Click
End Sub
Private Sub Form_Load()
End Sub
'*******************************************************************************
'* txtRuta_AfterUpdate
'* Rutina después de Actualizar Registro que muestra la imagen correspondiente al
'* nuevo registro
'* ESH 02/11/03 11:02
'*******************************************************************************
Private Sub txtRuta_AfterUpdate()
On Error GoTo txtRuta_AfterUpdate_TratamientoErrores
If Not IsNull(txtRuta) Then
MuestraImagen (txtRuta)
Else
Image.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_perro"
GoTo txtRuta_AfterUpdate_Salir
End Sub ' txtRuta_AfterUpdate
'*******************************************************************************
'* Dir
'* Comprueba la existencia de un archivo, mejora la función dir de VBA porque
'* esta devuelve falso si el archivo está oculto, es de sistema o solo lectura
'* Argumentos: strArchivo => nombre del archivo buscado incluida su ruta completa
'* uso: If Dir(strArchivo) Then
'* Juan M. Afan de Ribera
'* ESH 28/10/03 19:05
'*******************************************************************************
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_perro"
GoTo Dir_Salir
End Function ' Dir
si alguien me pudiera ayudar, se lo agradeceria mucho.
gracias.
Este es el generador de codigo.
miradlo y decirme algo, porfavor.
Option Compare Database
Private Sub btnPrimer_Click()
On Error GoTo Err_btnPrimer_Click
DoCmd.GoToRecord , , acFirst
Exit_btnPrimer_Click:
Exit Sub
Err_btnPrimer_Click:
MsgBox Err.Description
Resume Exit_btnPrimer_Click
End Sub
Private Sub btnAnterior_Click()
On Error GoTo Err_btnAnterior_Click
DoCmd.GoToRecord , , acPrevious
Exit_btnAnterior_Click:
Exit Sub
Err_btnAnterior_Click:
MsgBox Err.Description
Resume Exit_btnAnterior_Click
End Sub
Private Sub btnSeguent_Click()
On Error GoTo Err_btnSeguent_Click
DoCmd.GoToRecord , , acNext
Exit_btnSeguent_Click:
Exit Sub
Err_btnSeguent_Click:
MsgBox Err.Description
Resume Exit_btnSeguent_Click
End Sub
Private Sub btnUltim_Click()
On Error GoTo Err_btnUltim_Click
DoCmd.GoToRecord , , acLast
Exit_btnUltim_Click:
Exit Sub
Err_btnUltim_Click:
MsgBox Err.Description
Resume Exit_btnUltim_Click
End Sub
Private Sub btnBuscar_Click()
On Error GoTo Err_btnBuscar_Click
Screen.PreviousControl.SetFocus
DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
Exit_btnBuscar_Click:
Exit Sub
Err_btnBuscar_Click:
MsgBox Err.Description
Resume Exit_btnBuscar_Click
End Sub
Private Sub btnBusSeg_Click()
On Error GoTo Err_btnBusSeg_Click
Screen.PreviousControl.SetFocus
DoCmd.FindNext
Exit_btnBusSeg_Click:
Exit Sub
Err_btnBusSeg_Click:
MsgBox Err.Description
Resume Exit_btnBusSeg_Click
End Sub
Private Sub btnNou_Click()
On Error GoTo Err_btnNou_Click
DoCmd.GoToRecord , , acNewRec
Exit_btnNou_Click:
Exit Sub
Err_btnNou_Click:
MsgBox Err.Description
Resume Exit_btnNou_Click
End Sub
Private Sub btnBorrar_Click()
On Error GoTo Err_btnBorrar_Click
DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
Exit_btnBorrar_Click:
Exit Sub
Err_btnBorrar_Click:
MsgBox Err.Description
Resume Exit_btnBorrar_Click
End Sub
'abrir
Private Sub Comando112_Click()
On Error GoTo Comando112_Click_TratamientoErrores
Dim fd As FileDialog, _
strArchivo As String, _
vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogFilePicker)
' habilito la vista previa de la imagen
fd.InitialView = msoFileDialogViewPreview
' añado al filtro nº 2 algunos formatos de gráfico (el 1 y predeterminado es: todos los archivos)
fd.Filters.Add "Imagenes", "*.bmp; *.gif; *.jpg; *.jpeg; *.png; *.tif", 1
fd.Filters.Add "Todos los archivos", "*.*", 2
' establezco como filtro predetermiando el nº1
fd.FilterIndex = 1
' abro el cuadro de dialogo
If fd.Show = -1 Then
For Each vrtSelectedItem In fd.SelectedItems
strArchivo = CStr(vrtSelectedItem)
Next vrtSelectedItem
End If
Set fd = Nothing
' refresco la imagen
txtRuta = strArchivo
MuestraImagen (strArchivo)
Comando112_Click_Salir:
On Error GoTo 0
Exit Sub
Comando112_Click_TratamientoErrores:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en proc. Comando112_Click de Documento VBA Form_perro"
GoTo Comando112_Click_Salir
End Sub
'*******************************************************************************
'* Form_Current
'* Rutina Al Activar Registro que muestra la imagen correspondiente al registro actual
'* ESH 02/11/03 10:45
'*******************************************************************************
Private Sub Form_Current()
On Error GoTo Form_Current_TratamientoErrores
If Not IsNull(txtRuta) Then
MuestraImagen (txtRuta)
Else
Image.Picture = ""
End If
Form_Current_Salir:
On Error GoTo 0
Exit Sub
Form_Current_TratamientoErrores:
Image.Picture = ""
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en proc. Form_Current de Documento VBA Form_perro"
GoTo Form_Current_Salir
End Sub ' Form_Current
'*******************************************************************************
'* MuestraImagen
'* Muestra la imagen pasada como argumento
'* Argumentos: strRuta => Ruta del archivo imagen a mostrar
'* uso: MuestraImagen (Ruta)
'* ESH 02/11/03 10:43
'*******************************************************************************
Public Sub MuestraImagen(strRuta As String)
On Error GoTo MuestraImagen_TratamientoErrores
If Dir(strRuta) Then
Image.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_perro")
End Select
GoTo MuestraImagen_Salir
End Sub ' MuestraImagen
Private Sub Comando29_Click()
On Error GoTo Err_Comando29_Click
DoCmd.Close
Exit_Comando29_Click:
Exit Sub
Err_Comando29_Click:
MsgBox Err.Description
Resume Exit_Comando29_Click
End Sub
Private Sub Form_Load()
End Sub
'*******************************************************************************
'* txtRuta_AfterUpdate
'* Rutina después de Actualizar Registro que muestra la imagen correspondiente al
'* nuevo registro
'* ESH 02/11/03 11:02
'*******************************************************************************
Private Sub txtRuta_AfterUpdate()
On Error GoTo txtRuta_AfterUpdate_TratamientoErrores
If Not IsNull(txtRuta) Then
MuestraImagen (txtRuta)
Else
Image.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_perro"
GoTo txtRuta_AfterUpdate_Salir
End Sub ' txtRuta_AfterUpdate
'*******************************************************************************
'* Dir
'* Comprueba la existencia de un archivo, mejora la función dir de VBA porque
'* esta devuelve falso si el archivo está oculto, es de sistema o solo lectura
'* Argumentos: strArchivo => nombre del archivo buscado incluida su ruta completa
'* uso: If Dir(strArchivo) Then
'* Juan M. Afan de Ribera
'* ESH 28/10/03 19:05
'*******************************************************************************
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_perro"
GoTo Dir_Salir
End Function ' Dir
Valora esta pregunta


0