ACCESS FEED: RE: [belajar-access] Buka attachment field menggunakan coding VBA

Terimakasih Mas Sofyan, saya coba kotak-katik. Semoga Allah membalas. Aamiin

Salam,

widodo

From: belajar-access@yahoogroups.com [mailto:belajar-access@yahoogroups.com] On Behalf Of Sofyan Efendi
Sent: Monday, November 19, 2012 7:18 PM
To: belajar-access@yahoogroups.com
Subject: Re: [belajar-access] Buka attachment field menggunakan coding VBA

Dear Mas Widodo, terus terang saya sendiri belum coba menggunakan attachment. Tapi saya sudah pernah simpan kode VBA nya dari internet, namun saya lupa link sumbernya. Mudah2an ini bisa membantu.

Option Compare Database

' Module level constants used in these examples
Const m_strFieldFileName As String = "FileName" ' The name of the attached file
Const m_strFieldFileType As String = "FileType" ' The attached file's extension
Const m_strFieldFileData As String = "FileData" ' The binary data of the file

' -------------------------------------------------------------------------
' Sub/Func : AddAttachment
' Purpose : Saves the attachments at the current row of the open Recordset
' Arguments: rstCurrent - The recordset open at the current row to save
'          : strFieldName - The name of the attachment field
'          : strFilePath - The full path to the file to attach
' Comments : User must call .AddNew or .Edit on the incoming Recordset
'          : and then Recordset.Update when this returns to commit changes
' -------------------------------------------------------------------------
Sub AddAttachment(ByRef rstCurrent As DAO.Recordset, ByVal strFieldName As String, ByVal strFilePath As String)
    Const CALLER = "AddAttachment"
    On Error GoTo AddAttachment_ErrorHandler

Dim rstChild As DAO.Recordset2
Dim fldAttach As DAO.Field2

    If Dir(strFilePath) = "" Then ' the specified file does not exist!
        MsgBox "The specified input file does not exist: " & vbCrLf & strFilePath, vbCritical, "File not found"
        Exit Sub
    End If

    Set rstChild = rstCurrent.Fields(strFieldName).Value ' the .Value for a complex field returns the underlying Recordset.
    rstChild.AddNew ' add a new row to the child Recordset
    Set fldAttach = rstChild.Fields(m_strFieldFileData) ' set the DAO.Field2 object to the field that holds the binary data.
    fldAttach.LoadFromFile strFilePath ' store the file's contents in the new row.
    rstChild.Update ' commit the new row.
    rstChild.Close ' close the child Recordset.

    Exit Sub
AddAttachment_ErrorHandler:
    'Check for Run-time error '3820': (occurs if the file with the same name is already attached)
    'You cannot enter that value because it duplicates an existing value in the multi-valued lookup or attachment field.
    'Multi-valued lookup or attachment fields cannot contain duplicate values.
    Debug.Print "Error # " & Err.Number & " in " & CALLER & " : " & Err.Description
    If Err.Number <> 3820 Then
        MsgBox Err.Description, VbMsgBoxStyle.vbCritical, "Error # " & Err.Number & " in " & CALLER
        Debug.Assert False ' always stop here when debugging
    Else
        MsgBox "File of same name already attached", VbMsgBoxStyle.vbCritical, "Cannot attach file"
    End If
    Exit Sub
End Sub 'AddAttachment

' -------------------------------------------------------------------------
' Sub/Func : SaveAttachments
' Purpose : Saves the attachments at the current row of the open Recordset
' Arguments: rstCurrent - The recordset open at the current row to save
'          : strFieldName - The name of the attachment field
'          : strOutputDir - The folder to put the files in (e.g. "C:\Foo\")
' -------------------------------------------------------------------------
Sub SaveAttachments(ByRef rstCurrent As DAO.Recordset, ByVal strFieldName As String, ByVal strOutputDir As String)
    Const CALLER = "SaveAttachments"
    On Error GoTo SaveAttachments_ErrorHandler

    Dim rstChild As DAO.Recordset2
    Dim fldAttach As DAO.Field2
    Dim strFilePath As String

    If Right(strOutputDir, 1) <> "\" Then strOutputDir = strOutputDir & "\"
    Set rstChild = rstCurrent.Fields(strFieldName).Value ' The .Value for a complex field returns the underlying Recordset.
    While Not rstChild.EOF ' Loop through all of the attached files in the child Recordset.
        strFilePath = strOutputDir & rstChild.Fields(m_strFieldFileName).Value 'Append the name of the attached file to output directory.
        If Dir(strFilePath) <> "" Then ' The file already exists--delete it first.
            VBA.SetAttr strFilePath, vbNormal ' Remove any flags (e.g. read-only) that would block the kill command.
            VBA.Kill strFilePath ' Delete the file.
        End If
        Set fldAttach = rstChild.Fields(m_strFieldFileData) ' The binary data of the file.
        fldAttach.SaveToFile strFilePath
        rstChild.MoveNext ' Go to the next row in the child Recordset to get the next attached file.
    Wend
    rstChild.Close ' cleanup

    Exit Sub
SaveAttachments_ErrorHandler:
    Debug.Print "Error # " & Err.Number & " in " & CALLER & " : " & Err.Description
    MsgBox Err.Description, VbMsgBoxStyle.vbCritical, "Error # " & Err.Number & " in " & CALLER
    Debug.Assert False ' always stop here when debugging
    Resume Next
End Sub 'SaveAttachments

' -------------------------------------------------------------------------
' Sub/Func : RemoveAttachment
' Purpose : Removes the file from the attachments field in the currect row
' Arguments: rstCurrent - The recordset open at the current row to change
'          : strFieldName - The name of the attachment field
'          : strFileName - The name of the file to remove
' Comments : User must call .AddNew or .Edit on the incoming Recordset
'          : and then Recordset.Update when this returns to commit changes
' -------------------------------------------------------------------------
Sub RemoveAttachment(ByRef rstCurrent As DAO.Recordset, ByVal strFieldName As String, ByVal strFileName As String)
    Const CALLER = "RemoveAttachment"
    On Error GoTo RemoveAttachment_ErrorHandler

    Dim rstChild As DAO.Recordset2
    Dim fldAttach As DAO.Field2
    Dim strCurrent As String
    Dim strChop() As String

    Debug.Print "Parent row (ID) is: " & rstCurrent.Fields("ID").Value
    strChop = Split(strFileName, "\") ' This chops the file name up into into an array of strings delimited by "\".
    strFileName = UCase(strChop(UBound(strChop))) ' The last element in the returned array is the filename.
    Set rstChild = rstCurrent.Fields(strFieldName).Value ' the .Value for a complex field returns the underlying Recordset.
    While Not rstChild.EOF ' Loop through all of the attached files in the child Recordset.
        strCurrent = rstChild.Fields(m_strFieldFileName) ' The name of the file in the current row of the child Recordset.
        If UCase(strCurrent) = strFileName Then ' we found the attachment to be removed--delete it.
            rstChild.Delete ' There is no need to call rstChild.Edit first because the parent Recordset is in Edit mode.
            rstChild.Close
            Exit Sub ' We're done removing the file.
        End If
        rstChild.MoveNext ' The file to remove was not the current one--move to the next row of the child Recordset.
    Wend
    rstChild.Close ' cleanup

    Exit Sub
RemoveAttachment_ErrorHandler:
    Debug.Print "Error # " & Err.Number & " in " & CALLER & " : " & Err.Description
    Debug.Assert False ' always stop here when debugging
    MsgBox Err.Description, VbMsgBoxStyle.vbCritical, "Error # " & Err.Number & " in " & CALLER
    Resume Next
End Sub 'RemoveAttachment

' -------------------------------------------------------------------------
' Sub/Func : TestAddRemoveAndSave
' Purpose : Test AddAttachment(), RemoveAttachment(), and SaveAttachments()
' -------------------------------------------------------------------------
Sub TestAddRemoveAndSave()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset

Const strTable = "Table1"
Const strField = "Files" ' Attachment field in Table1

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strTable)

    ' Add a new row and an attachment
    rst.AddNew
    AddAttachment rst, strField, "C:\Windows\Media\chimes.wav"
    rst.Update
    rst.MoveLast

    ' Add another attachment to the last row
    rst.Edit
    AddAttachment rst, strField, "C:\Windows\Media\chord.wav"
    rst.Update

    ' Remove the first attachment from the last row
    rst.Edit
    RemoveAttachment rst, strField, "chimes.wav"
    rst.Update

    If Dir("C:\Foo\", vbDirectory) = "" Then MkDir "C:\Foo"
    SaveAttachments rst, strField, "C:\Foo\"
    rst.Close
End Sub 'TestAddRemoveAndSave

Wassalaamu'alaikum Warahmatullahi Wabarakatuh,
Sofyan Efendi
http://imopi.wordpress.com | http://trendmuslim.com
Access Course by Request [Offline & Online] : http://wp.me/PW3LC-hR

----- Original Message -----

From: Widodo

To: belajar-access@yahoogroups.com

Sent: Wednesday, November 21, 2012 12:58 PM

Subject: [belajar-access] Buka attachment field menggunakan coding VBA

Dear Para Master,

Mohon bantuannya untuk membuka file yang disimpan di database (attachment field) menggunakan coding VBA, sebagai informasi setiap record hanya menyimpan satu file dokumen. Filenya berbentuk dokumen.

Terimakasih sebelumnya

Salam

Widodo