طلب كود انشاء مجلدات في الهارديسك

[r3dx]

السلام عليكم ورحمة الله وبركاته مساء و صباح الخير 🌹 

اعتذر لعدم التوسع في شرح طلبي  ولكن اكتب من جوالي الآن وانتم تقدرون 

 عندي مجموعة اسماء تزيد عن 100 اسم هل اجد كود بضغطه واحده ينشأ لكل اسم مجلد مستقل 

 

اتمنى الإجابه ووضع الحل بارك الله فيكم جميعاً 

 

[د.كاف يار]

تفضل اخي الكريم

Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Dim MyFolderName As String
	MyFolderName= "عنصر التحكم او اسم المجلد"

Set fso = CreateObject("scripting.filesystemobject")

          fldrpath = CurrentProject.Path & "\" & MyFolderName

          If Not fso.FolderExists(fldrpath) Then
             fso.createfolder (fldrpath)
             
          End If

 

[r3dx]

جزاك الله كل وبارك فيك وفي علمك 

وطلب اخير تطبيق صغير لتنفيذ الداله عليه لأني ما عرفة اطبقه واعذرني على الإزعاج 

[د.كاف يار]

4 ساعات مضت, shoooq said:

جزاك الله كل وبارك فيك وفي علمك 

وطلب اخير تطبيق صغير لتنفيذ الداله عليه لأني ما عرفة اطبقه واعذرني على الإزعاج 

مرفق التطبيق

MyData.accdb

[r3dx]

الف مليون شكر لك 

 

جزاك الله خير وكثر من امثالك ونفع بك وبعلمك

[saaad 213]

موضوع اعجبني ولكن هل من الممكن نسخ ملف واعادة تسمية بالرقم الوظيفي للموظفين

[د.كاف يار]

منذ ساعه, saaad 213 said:

موضوع اعجبني ولكن هل من الممكن نسخ ملف واعادة تسمية بالرقم الوظيفي للموظفين

 

اخي الكريم

لإنشاء مجلد بالرقم الوظيفي استخدم الكود التالي

    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String
    Dim strSQL As String
    Dim MyFields As String
    Dim rs As DAO.Recordset
    MyFields = "اسم عمود الرقم الوظيفي في الجدول"
    Set rs = CurrentDb.OpenRecordset("اسم الجدول")
    
    If Not rs.BOF And Not rs.EOF Then
            rs.MoveFirst
                 
        While (Not rs.EOF)
            Set fso = CreateObject("scripting.filesystemobject")
                fldrpath = CurrentProject.Path & "\" & rs.Fields(MyFields)
          
          If Not fso.FolderExists(fldrpath) Then
             fso.createfolder (fldrpath)
             Me.FolderPath = CurrentProject.Path & "\" & rs.Fields(MyFields)
          End If

            rs.MoveNext
        Wend
    End If
    rs.Close
    Set rs = Nothing

 

و لنسخ ملف استخدم الكود التالي

    Dim MyFields As String
    Dim rs As DAO.Recordset
    	MyFields = "الرقم الوظيفي"

    Dim Addfile As Object
Set Addfile = Application.FileDialog(3)
With Addfile
  .AllowMultiSelect = False
  .InitialFileName = ""
  .Filters.Clear
  .Filters.Add "All Files", "*.*"
  If .Show = True Then
      
      Dim MyFile, DstFile, MyFileTayb As String
      Dim Syso As Object
      
        MyFile = Trim(.SelectedItems(1))
        DstFile = CurrentProject.Path & "\" & MyFields & Right(MyFile, 4)
            
        DBEngine.Idle

    Set Syso = CreateObject("Scripting.FileSystemObject")
        Syso.copyfile MyFile, DstFile
    Set Syso = Nothing


      Else
      Exit Sub
  End If
End With

 

[saaad 213]

مشكور - لم يعمل جيدا ارجو ارفاق مثال

تم تعديل أكتوبر 30, 2020 بواسطه saaad 213

[د.كاف يار]

12 ساعات مضت, saaad 213 said:

مشكور - لم يعمل جيدا ارجو ارفاق مثال

تفضل المثال

MyData.accdb

[saaad 213]

مشكووووووووور هذا المطلوب