Sofyan Efendi
http://imopi.wordpress.com | http://trendmuslim.com
Access Course by Request [Offline & Online] : http://wp.me/PW3LC-hR
----- Original Message -----From: WidodoSent: Thursday, November 22, 2012 12:06 PMSubject: RE: [belajar-access] Buka attachment field menggunakan coding VBATerimakasih 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 'TestAddRemoveAndSaveWassalaamu'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
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
| Reply via web post | Reply to sender | Reply to group | Start a New Topic | Messages in this topic (4) |
No comments:
Post a Comment