مساعدة في حفظ مسار ملف ( اضافة - فتح - حذف )

[ازهر عبد العزيز]

السلام عليكم 

احتاج كود تحت زر بحيث عند الضغط على هذا الزر يفنح مستعرض الملفات وعند الضغط على الملف المطلوب يقوم بتخزين مسار هذا الملف في حقل داخل النموذج وليكن اسمه filesource دون فتح الملف ثم يغلق مستعرض الملفات 

[Moosak]

وعليكم السلام أخي أزهر 🙂 

طلبط بسيط بإذن الله ، ولكن سأعرض عليك خدمات أكثر 😊

- هل تريد نقل الملف أيضا إلى مجلد بجانب قاعدة البيانات ؟

- وإضافة زر لفتح الملف .. ؟

- وزر آخر لحذفه ؟

إذا كانت إجابتك بنعم .. فسأرفق لك الأكواد ..

 

أما إذا كنت فقط ستكتفي بالسؤال فهذا هو الكود الذي طلبته 🙂 :

    On Error GoTo ErrHandler
    
    Dim fd As Object
    Dim filedialogPath As String
    
    Set fd = Application.FileDialog(1)
    
    fd.AllowMultiSelect = False
    fd.Title = "حدد الملف المطلوب"
    fd.Filters.Clear
    fd.Filters.Add "كل الملفات", "*.*"
      
    If fd.Show = True Then
    'Debug.Print fd.SelectedItems(1)
    Me.filesource = fd.SelectedItems(1)
    Else
    MsgBox "لم تقم باختيار أي ملف"
    Exit Sub
    End If

ErrHandler:
    If Err.Number = 0 Then
    Exit Sub
    Else
    MsgBox "Error Number : " & Err.Number & " :::: " & Err.Description
    End If

 

[ازهر عبد العزيز]

16 ساعات مضت, Moosak said:

إذا كانت إجابتك بنعم .. فسأرفق لك الأكواد ..

 

[Moosak]

تفضل أخي أزهر 🙂 

(1) هذه الأكواد الاثلاثة لأزرار [إضافة ملف] و [فتح الملف] و [حذف الملف] :

Private Sub AddFilesBtn_Click()
'================================================================ هذا الجزء يوضع على الزر الذي يضيف الملف
Dim file As String
Dim fileName As String
Dim SavePath As String

If Me.NewRecord Then MsgBox "أكتب التفاصيل أولا", vbOKOnly, "": Exit Sub

file = selectFile
If IsBlank(file) Then Exit Sub
fileName = GetFileName(file)
SavePath = BECurrentPath & "attachments\" & [ID] & "\" & fileName

' يتم حفظ الملف في مجلد المرفقات بجانب قاعدة البيانات في مجلد بنفس رقم الآيدي
MkDir (BECurrentPath & "attachments\")
MkDir (BECurrentPath & "attachments\" & [ID] & "\")

FileCopy file, SavePath
' حفظ المسار في مربع النص
Me.filepath = fileName
Me.Refresh

MsgBox "تم إضافة الملف بنجاح"

End Sub


'================================================================ هذا الجزء يوضع على الزر الذي يفتح الملف
Private Sub BrowserBtn_Click()
    
    On Error GoTo ErrorFix
     
    If Not IsBlank(Me.filepath) Then
        If IsFileExists(Me.filepath) = False Then
        MsgBox "لا يمكن العثور على الملف"
        Else
        OpenPath Me.filepath
        End If
        Exit Sub
    Else
        MsgBox "لا يوجد مرفقات"
        Exit Sub
    End If
    
ErrorFix:
    If Err.Number = 0 Then
    On Error Resume Next
    Else
    MsgBox Err.Number & "\\\" & Err.Description
    End If
End Sub


'================================================================ هذا الجزء يوضع على زر الحذف
Private Sub DeletBtn_Click()
On Error GoTo whathapen
 
If MsgBox("هل أنت متأكد من رغبتك في حذف المرفق ؟", vbYesNo, "تأكيد الحذف") = vbYes Then
Else
Exit Sub
End If
 
     If Not IsBlank(Me.filepath) Then
         
         If IsFileExists(Me.filepath) = False Then
             MsgBox "لا يمكن العثور على الملف"
             Exit Sub
         Else
             DleteFolder BECurrentPath & "attachments\" & [ID]
             Me.Attachment = ""
             MsgBox "تم حذف الملف"
             Exit Sub
         End If
     
    Else
        MsgBox "لا توجد مرفقات"
        Exit Sub
     End If
         
whathapen:
    If Err.Number = 53 Then
    MsgBox "لا توجد ملفات لحذفها"
    Exit Sub
    ElseIf Err.Number = 0 Then
    On Error Resume Next
    Else
    MsgBox Err.Number & "\\\" & Err.Description
    End If
End Sub

 

(2) وهذه الأكواد ضرورية لتشغيل الأكواد السابقة .. ضعها في موديول منفصل :

Public Function selectFile()

    On Error GoTo ErrHandler
    
    Dim fd As FileDialog
    Dim filedialogPath As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    fd.AllowMultiSelect = False
    fd.Title = "حدد الملف المطلوب"
'    fd.InitialFileName = CurrentProject.Path
    fd.Filters.Clear
    fd.Filters.Add "كل الملفات", "*.*"
      
    If fd.Show = True Then
    selectFile = fd.SelectedItems(1)
'    Exit Function
    Else
    MsgBox "لم تقم باختيار أي ملف"
    Exit Function
    End If

ErrHandler:
    If Err.Number = 0 Then Exit Function Else
    MsgBox "Error Number : " & Err.Number & " :::: " & Err.Description
'    End If
    
End Function
      
Public Function IsBlank(arg As Variant) As Boolean
    Select Case VarType(arg)
        Case vbEmpty
            IsBlank = True
        Case vbNull
            IsBlank = True
        Case vbString
            IsBlank = (LenB(arg) = 0)
        Case vbObject
            IsBlank = (arg Is Nothing)
        Case Else
            IsBlank = IsMissing(arg)
    End Select
End Function

Public Function GetFileName(txtPath As String) As String

' To Extract File Name From A given Path
GetFileName = Right(txtPath, Len(txtPath) - InStrRev(txtPath, "\"))

End Function
  
Public Function IsFileExists(txtPath As String) As Boolean

' To check whether a given file or folder exists or not

If Len(Dir(txtPath, vbDirectory)) = 0 Then
   IsFileExists = False
Else
   IsFileExists = True
End If

End Function

Public Sub OpenPath(strpath As String)
	Shell "explorer.exe" & " " & strpath, vbNormalFocus
End Sub

Public Function DleteFolder(FolderPath As String)
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFolder FolderPath, True
Set fs = Nothing
End Function
                                                     
                                                     
Public Function BECurrentPath()

    On Error GoTo ErrHandler

    Dim FullLinkedPath As String
    Dim LinkedDBPath As String

    FullLinkedPath = Nz(DLookup("Database", "MSysObjects", "Type=6"), "")

   If FullLinkedPath <> "" Then
    LinkedDBPath = Left(FullLinkedPath, InStrRev(FullLinkedPath, "\") - 1)    
    BECurrentPath = LinkedDBPath & "\"
    
    Else
    
    BECurrentPath = CurrentProject.Path & "\"
   
    End If
ErrHandler:
    If Err.Number = 0 Then Exit Function Else
    MsgBox "Error Number : " & Err.Number & " :::: " & Err.Description
End Function

 

[أحمد محمد اسماعيل عامر]

عملت السابق 

ولكن بيطلع خطأ باللون الأصفر على دالة 

selectFile

Error: ambiguous name detected access

 

عندي 4 ملفات Attatchment في الفورم الواحد 

 

كيف أربط الأزرار بخانة "Attatchment" ليقوم بعمل السابق

 

 

 هل أربطه بخانة تيكست لمسار الملف ولا ما هي المعايير المطلوبة لتنفيذه داخل الفورم

 

 @Moosakوشكرا

تم تعديل أبريل 1, 2023 بواسطه أحمد محمد اسماعيل عامر

[Moosak]

2 ساعات مضت, أحمد محمد اسماعيل عامر said:

بيطلع خطأ باللون الأصفر على دالة 

selectFile

هذه الدالة موجودة هنا .. يجب نقل هذا الجزء لبرنامجك :

في ٤‏/٢‏/٢٠٢٣ at 10:52, Moosak said:

(2) وهذه الأكواد ضرورية لتشغيل الأكواد السابقة .. ضعها في موديول منفصل :

وبالنسبة لهذه الجزئية :

2 ساعات مضت, أحمد محمد اسماعيل عامر said:

كيف أربط الأزرار بخانة "Attatchment" ليقوم بعمل السابق

تكرر الكود الخاص بإضافة الملف لكل زر عندك .. فقط تغير هذا الجزء ليتم حفظ كل ملف في مكانه المناسب :

في ٤‏/٢‏/٢٠٢٣ at 10:52, Moosak said:

' حفظ المسار في مربع النص
Me.filepath = fileName

 

2 ساعات مضت, أحمد محمد اسماعيل عامر said:

Moosakوشكرا

عفوا 🙂🌹

[أحمد محمد اسماعيل عامر]

عملت كل شئ

 

نفس الخطأ

الفورم FrmWeeklyRep

الموديول رقم 3

 

مرفق لحضراتكم الملف وجزاكم الله خيرا

vb4arb.rar

[أحمد محمد اسماعيل عامر]

Moosak 

 

هل وجدت حل للمشكلة اللي بالملف؟

[Moosak]

1 ساعه مضت, أحمد محمد اسماعيل عامر said:

هل وجدت حل للمشكلة اللي بالملف؟

نعم أخي أحمد 🙂 

لديك العديد من الأخطاء .. يبدو أنك نقلت الكود كما هو بدون أن تغير فيه القيم الموجودة في برنامجك ..

1 - ليس لديك حقل اسمه [ID] ، الحقل عندك اسمه [IDRep]

2- هذا المفروض يكون اسم الحقل الذي تحفظ فيه رابط الملف .. ولكنه غير موجود ، وتحتاج لإضافة 4 حقول لأن لديك 4 صور ..

3 - مكرر .. تزيله

4 - وجدت أنك كررت الدالة selectFile مرتين في موديولين مختلفين لذلك لم تعمل معك .. الحل أن تحذف واحدة وتبقي الأخرى .

5 - وكذلك لديك 8 مكتبات مفقودة ، يجب عليك أن تصلحها :

6- تابع الأكواد التي نسختها من هنا حتى آخرها وغير أسماء الحقول حسب الحقول الموجودة عندك :

7- الحقول ال4 التي في النموذج هي حقول مرفقات .. بينما المفروض أنها تكون حقول [صور] :

8- أسفل كل حقل من حقول الصور تضيف حقل نصي (تضيفها في الجدول أولا ) وذلك لتخزين مسارات الصور ... وتجعلها مخفية في النموذج .

[kkhalifa1960]

في 2‏/2‏/2023 at 15:36, ازهر عبد العزيز said:

احتاج كود تحت زر بحيث عند الضغط على هذا الزر يفنح مستعرض الملفات وعند الضغط على الملف المطلوب يقوم بتخزين مسار هذا الملف في حقل داخل النموذج وليكن اسمه filesource دون فتح الملف ثم يغلق مستعرض الملفات

اساتذتي الافاضل يبدو أنكم نسيتوا هديتي لكم التي بها كل ماطلبتم وهاهي مرةً أخرى .