وهذه طريقة أخرى مشاركة مع العمدة @jjafferr
Sub SaveAttachmentAll(Optional FilePath)
On Error Resume Next
Dim Rs As DAO.Recordset, RsA As DAO.Recordset
Dim NewFileName, Rc, Sn
Set Rs = Me.RecordsetClone
Rs.MoveFirst
'Loop throu All record
Do Until Rs.EOF
'Set attachment db
Set RsA = Rs("pic").Value
'Get record count
If RsA.RecordCount = 0 Then Exit Sub
RsA.MoveLast
Rc = RsA.RecordCount
RsA.MoveFirst
' Loop throu current record attachments
Do Until RsA.EOF
' make Sequence if more one attachment
If Rc > 1 Then Sn = RsA.AbsolutePosition
'if no file path provide, get db path
If IsMissing(FilePath) Then
FilePath = CurrentProject.Path & "\Images\"
End If
' Make new file name
NewFileName = Rs("جلوس") & Sn & "." & RsA("filetype")
' Save attached file to new file name
RsA("FileData").SaveToFile FilePath & NewFileName
RsA.MoveNext
Loop
Rs.MoveNext
Loop
Set Rs = Nothing
Set RsA = Nothing
End Sub
ثم استدعيه من الزر
Call SaveAttachmentAll
kan.rar