كود حفظ المرفقات في الخادم

[eng aoff]

السلام عليكم اساتذتي الكرام كل عام وانتم بالف خير اسال الله ان يتقبل منا ومنكم صالح الاعمال

....انا بحاجة الى تعديل الكود لان محاولاتي ما نفعت ...اريد حفظ المرفقات في الخادم لو سمحتو ... المشكلة عند تقسيم قاعدة البيانات وتحويل النماذج الى المستخدمين لا يجلب المرفقات بسسب عدم وجود المجلدات التابعة للمرفق في حواسيب المستخدمين وعند انشاء المجلدات في حواسيب المستخدمين يحفظ المرفقات عندهم فقظ اما البيانات فتحفظ في الجداول الرئيسية في الخادم ارجو المساعدة اساتذتي... ولكم جزيل الشكر والتقدير

Dim path_folder_attaced As String
If IsNull([id]) Or IsNull([number]) Or IsNull([data]) Or IsNull(name_Arc) Or IsNull([name_Arc]) Then
Dim my_msg As String

    my_msg = MsgBox("لن يتم إرفاق اى ملفات لعدم إكتمال كل البيانات" & vbCrLf & _
    "-  رقم الكتاب" & vbCrLf & _
    "- تاريخ الكتاب" & vbCrLf & _
    "-موضوع الكتاب", _
    vbOKOnly, _
    "خطـــــأ")

'Call add_id_new_rec

Else

path_folder_attaced = db_path() & "مرفقات " & "\صادر \" & [id] & "\"
If Dir(path_folder_attaced, vbDirectory) = "" Then
MkDir path_folder_attaced
End If

Me.pate = path_folder_attaced

On Error GoTo err_cmd_Open_desktob_Click

    Dim strFileNames As Variant
    Dim strFilter
    Dim sFolder
    Dim SelectedFiles
    
    strFilter = "All Files " & _
             "(*.*)" & vbNullChar & _
              "*.*" & vbNullChar & vbNullChar
    sFolder = "C:\"
    
    ' call the API for the Multi File Dialog
    strFileNames = apiBrowseFiles("Select a File, OR Multiple Files", sFolder, , strFilter)
    
    ' user didn't select any file, s/he proceed cancel
    If UBound(strFileNames) = 0 Then
        Exit Sub
    End If
    
    SelectedFiles = UBound(strFileNames) ' number of selected files
        
    ' take the 1st file name and extract the Folder name from it
    ' Don't Dim sFolder, it has been declared as Global variable
    ' so that the last folder visited will be opened again
    sFolder = strFileNames(1)
    Do While Right(sFolder, 1) <> "\"
      sFolder = Left(sFolder, Len(sFolder) - 1)
    Loop
    sFolder = Replace(sFolder, "\\", "\")

    Dim RC
    Dim I
    
    Set rst = Me.frm_Sub_attachmentssrk.Form.RecordsetClone
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    
    
    ' Add the selected items, and seperate them by a ; so that we use it as Row Source for
    ' list the files selected in the Listbox lstMultipleFiles
    For I = 1 To UBound(strFileNames)
        
        Dim File_Path_Name
        Dim FileExt
        Dim File_Name
        Dim New_File
        
        File_Path_Name = Replace(strFileNames(I), "\\", "\")
        FileExt = mID(strFileNames(I), InStrRev(strFileNames(I), ".") + 1)
        FileExt = IIf(FileExt = File_Path_Name, "", FileExt) 'file has No Extension
        File_Name = Replace(File_Path_Name, sFolder, "")
        New_File = "image" & Me.id & "_" & I + RC & "." & FileExt
        
        ' Copy the original file to Folder in the main Form
        FileCopy File_Path_Name, Me.pate & "\" & New_File
    
                rst.AddNew
                    rst!name_morfke = New_File
                    rst!tayp = FileExt
                    
                    rst!emp_id = Me.id
                rst.Update
    Next I

Exit_cmd_Open_desktob_Click:
Exit Sub
err_cmd_Open_desktob_Click:

    If err.number = 3021 Then
        RC = 0
        Resume Next
    Else
        MsgBox err.number & vbCrLf & err.Description
    End If

End If

 

[ابوخليل]

تفضل في هذا الموضوع تجد ما تبحث عنه

 

[eng aoff]

جزاك الله خيرا استاذي العزيز ... حاولت ولم افلح