فتح او حفظ المرفق بضغط على الزر

[Ibrahim IQ]

السلام عليكم ....

هل ممكن فتح او حفظ المرفق فونت هو في القاعدة بزر عند ضغط على الزر في النموذج افتح المرفق ببرنامج (winrar)   مع التحياتي

fonts.rar

[صالح حمادي]

السلام عليكم

أخي تفضل هذه هي الأكواد التي تحتاجها:

1- بالنسبة لحفظ المرفق بمكان معين في الكمبيوتر:

Set db = CurrentDb
Set rstable = db.OpenRecordset("tblFonts")
Set rsfile = rstable.Fields("attach").Value
rsfile.Fields("FileData").SaveToFile txtpath

بحيث : txtpath هو مسار الحفظ

و إذا أردنا فتح الملف بعد حفظه مباشرة نضيف هذا الكود:

Application.FollowHyperlink txtpath & "\" & rsfile.Fields("Filename")

2- أما بالنسبة لفتح المرفق مباشرة فنستعمل هذا الكود:

Dim db As DAO.Database
Dim rsEmployees As DAO.Recordset
Set db = CurrentDb
Set rsEmployees = db.OpenRecordset("tblFonts")
OpenFirstAttachmentAsTempFile rsEmployees, "attach"

و نحفظ الكود التالي في وحدة نمطية جديدة:

Public Function OpenFirstAttachmentAsTempFile(ByRef rstCurrent As DAO.Recordset, ByVal strFieldName As String) As String
Dim rstChild As DAO.Recordset2
Dim fldAttach As DAO.Field2
Dim strFilePath As String
Dim strTempDir As String
strTempDir = Environ("Temp") ' Get the Temp directory from the environment variable.
If Right(strTempDir, 1) <> "\" Then strTempDir = strTempDir & "\" ' Make sure the path always ends with a backslash.
Set rstChild = rstCurrent.Fields(strFieldName).Value ' the .Value for a complex field returns the underlying recordset.
strFilePath = strTempDir & rstChild.Fields("FileName").Value ' Append the name of the first (and only) attached file to temp dir.
If Dir(strFilePath) <> "" Then ' the file already exists--delete it first.
VBA.SetAttr strFilePath, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill strFilePath ' delete the file.
End If
Set fldAttach = rstChild.Fields("FileData") ' The binary data of the file.
fldAttach.SaveToFile strFilePath
rstChild.Close ' cleanup
VBA.Shell "Explorer.exe " & Chr(34) & strFilePath & Chr(34), vbNormalFocus ' Use Windows Explorer to launch the file.
End Function 'OpenFirstAttachmentAsTempFile

و هذا ملفك بعد التعديل:

 

fonts.rar

[Ibrahim IQ]

في 4/12/2017 at 13:02, صالح حمادي said:

السلام عليكم

أخي تفضل هذه هي الأكواد التي تحتاجها:

1- بالنسبة لحفظ المرفق بمكان معين في الكمبيوتر:

Set db = CurrentDb
Set rstable = db.OpenRecordset("tblFonts")
Set rsfile = rstable.Fields("attach").Value
rsfile.Fields("FileData").SaveToFile txtpath

بحيث : txtpath هو مسار الحفظ

و إذا أردنا فتح الملف بعد حفظه مباشرة نضيف هذا الكود:

Application.FollowHyperlink txtpath & "\" & rsfile.Fields("Filename")

2- أما بالنسبة لفتح المرفق مباشرة فنستعمل هذا الكود:

Dim db As DAO.Database
Dim rsEmployees As DAO.Recordset
Set db = CurrentDb
Set rsEmployees = db.OpenRecordset("tblFonts")
OpenFirstAttachmentAsTempFile rsEmployees, "attach"

و نحفظ الكود التالي في وحدة نمطية جديدة:

Public Function OpenFirstAttachmentAsTempFile(ByRef rstCurrent As DAO.Recordset, ByVal strFieldName As String) As String
Dim rstChild As DAO.Recordset2
Dim fldAttach As DAO.Field2
Dim strFilePath As String
Dim strTempDir As String
strTempDir = Environ("Temp") ' Get the Temp directory from the environment variable.
If Right(strTempDir, 1) <> "\" Then strTempDir = strTempDir & "\" ' Make sure the path always ends with a backslash.
Set rstChild = rstCurrent.Fields(strFieldName).Value ' the .Value for a complex field returns the underlying recordset.
strFilePath = strTempDir & rstChild.Fields("FileName").Value ' Append the name of the first (and only) attached file to temp dir.
If Dir(strFilePath) <> "" Then ' the file already exists--delete it first.
VBA.SetAttr strFilePath, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill strFilePath ' delete the file.
End If
Set fldAttach = rstChild.Fields("FileData") ' The binary data of the file.
fldAttach.SaveToFile strFilePath
rstChild.Close ' cleanup
VBA.Shell "Explorer.exe " & Chr(34) & strFilePath & Chr(34), vbNormalFocus ' Use Windows Explorer to launch the file.
End Function 'OpenFirstAttachmentAsTempFile

و هذا ملفك بعد التعديل:

 

fonts.rar

لا اعرف كيف اشكرك استاذ ( صالح ) ؟؟؟؟؟ شكرا جزيلا الله يحفظك