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
SelectionFile type iconFile nameDescriptionSizeRevisionTimeUser
ċ
Descargar		   222 kb v. 1 4 ene. 2014 21:10 Jefferson Jimenez
Comments