Datos Adjunto usando VBA
Como extraer datos adjunto usando VBA DAO
Option Compare Database
'************************************************************
'& &*
'& : || : &*
'& || &*
'& || &*
'& || &*
'& . - || - . &*
'& ( || ) &*
'& ) ( || ) ( &*
'& / || \ &*
'& ( || ) &*
'& ` ` &*
'& ` ____ ' &*
'& &*
'& Jefferson Jimenez (JJJT) &*
'& Cabimas - Venezuela &*
'& Enero - 2014 &*
'& &*
'& &*
'& &*
'& &*
'& &*
'************************************************************
'PARA MAS INFORMACION AL RESPECTO REVISE LA AYUDA DE ACCESS
'CITO...:
'El fragmento de código siguiente utiliza el método LoadFromFile para cargar la imagen de un empleado del disco.
' Instantiate the parent recordset.
' Set rsEmployees = db.OpenRecordset("Employees")
' … Code to move to desired employee
' Activate edit mode.
' rsEmployees.Edit
' Instantiate the child recordset.
' Set rsPictures = rsEmployees.Fields("Pictures").Value
' Add a new attachment.
' rsPictures.AddNew
' rsPictures.Fields("FileData").LoadFromFile "EmpPhoto39392.jpg"
' rsPictures.Update
' Update the parent record
' rsEmployees.Update
Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Declare Function JJJTExisteFile Lib "shlwapi.dll" Alias "PathFileExistsA" _
(ByVal pszPath As String) As Boolean
Public StrAdjunto As String
Public RutaE As String
Sub LeeAdjunto(StrSQL As String, ElCampoAdj As String, IDData As Long, AgregaList As Access.ListBox)
Dim rsTabla As Recordset
Dim rsArchivo As Object
On Local Error GoTo VerError
AgregaList.RowSource = ""
Set rsTabla = CurrentDb.OpenRecordset(StrSQL)
Set rsArchivo = rsTabla.Fields(ElCampoAdj).Value
While Not rsArchivo.EOF
AgregaList.AddItem rsArchivo.Fields("FileName").Value
rsArchivo.MoveNext
Wend
rsArchivo.Close
rsTabla.Close
Set rsTabla = Nothing
Exit Sub
VerError:
If Err.Number <> 3021 Then
MsgBox "Error # " & Err.Number & vbCrLf & Err.Description, vbInformation
End If
End Sub
Sub ExtraeAdj(StrSQL As String, ElCampoAdj As String, IDData As Long)
Dim rsTabla As Recordset
Dim rsCampo As Object
On Local Error GoTo VerError
Set rsTabla = CurrentDb.OpenRecordset(StrSQL)
Set rsCampo = rsTabla.Fields(ElCampoAdj).Value
RutaE = CurrentProject.Path & "\" & StrAdjunto
If JJJTExisteFile(RutaE) = False Then
While Not rsCampo.EOF
If rsCampo.Fields("FileName") = StrAdjunto Then
rsCampo.Fields("FileData").SaveToFile RutaE
End If
rsCampo.MoveNext
Wend
rsCampo.Close
rsTabla.Close
Set rsTabla = Nothing
End If
Exit Sub
VerError:
If Err.Number <> 3021 Then
MsgBox "Error # " & Err.Number & vbCrLf & Err.Description, vbInformation
End If
End Sub