شخابيط و افكار : انشاء مجلد او هيكل مجلدات رئيسية وفرعيه ( فكره مطروحه للتجربه والنقاش )

[ابو جودي]

السلام عليكم ورحمة الله تعالى وبركاته

الموضوع بخصوص انشاء مجلدات 

الموضوع مطروح للتجربه والنقاش بفكره جديده تشمل كل الاحتمالات تقريبا التى خطرت على بالى
 

الاكواد فى وحدة نمطيه عامة كالاتى

' استيراد كائن FileSystemObject
Private fso As Object

' تهيئة كائن FileSystemObject
Private Sub InitializeFSO()
    If fso Is Nothing Then
        Set fso = CreateObject("Scripting.FileSystemObject")
    End If
End Sub

' فحص وجود مجلد باستخدام FileSystemObject
Private Function FolderExists(path As String) As Boolean
    InitializeFSO
    FolderExists = fso.FolderExists(path)
End Function

' إنشاء بنية مجلدات متدرجة
Private Function CreateFolderStructure(fullPath As String, ByRef errorMessage As String) As Boolean
    On Error GoTo ErrorHandler
    Dim parts() As String
    Dim currentPath As String
    Dim i As Integer
    
    ' تقطيع المسار إلى أجزاء
    parts = Split(fullPath, "\")
    currentPath = ""
    
    ' إنشاء كل جزء من المسار بشكل متدرج
    For i = LBound(parts) To UBound(parts)
        If parts(i) <> "" Then
            currentPath = currentPath & parts(i) & "\"
            If Not FolderExists(currentPath) Then
                fso.CreateFolder currentPath
            End If
        End If
    Next
    
    CreateFolderStructure = True
    Exit Function
    
ErrorHandler:
    ' تخزين رسالة الخطأ في حال حدوث مشكلة
    errorMessage = "تعذر إنشاء المجلد: " & fullPath & " - الخطأ: " & Err.Description
    CreateFolderStructure = False
End Function

' بناء مسار كامل من المسار الأساسي والمسار الفرعي
Private Function BuildPath(basePath As String, subPath As String) As String
    ' التأكد من انتهاء المسار الأساسي بشرطة ميل (/)
    If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
    ' استبدال شرط الميل ("/") بشريط الميل ("\")
    BuildPath = basePath & Replace(subPath, "/", "\")
End Function

' تنظيف المسار وإصلاح الأخطاء الشائعة
Function BuildFullPath(rawPath As String) As String
    Dim cleanPath As String

    ' إزالة الفراغات الزائدة واستبدال الرموز غير الصحيحة
    cleanPath = Trim(rawPath)
    cleanPath = Replace(cleanPath, "/", "\")

    ' تصحيح الأخطاء في بداية المسار (C\Test ? C:\Test)
    If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" And (Asc(UCase(Left(cleanPath, 1))) >= 65 And Asc(UCase(Left(cleanPath, 1))) <= 90) Then
        cleanPath = Left(cleanPath, 1) & ":\" & Mid(cleanPath, 3)
    End If

    ' التحقق مما إذا كان المسار يبدأ بحرف قرص (مثل C:) لكنه لا يحتوي على \ بعده، وإصلاحه
    If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = ":" And Mid(cleanPath, 3, 1) <> "\" Then
        cleanPath = Left(cleanPath, 2) & "\" & Mid(cleanPath, 3)
    End If

    If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" Then
        cleanPath = Left(cleanPath, 1) & ":\" & Right(cleanPath, Len(cleanPath) - 2)
    End If

    ' إذا لم يحتوي المسار على رمز قرص أو مسار شبكة، يتم ربطه بمسار المشروع الحالي
    If InStr(cleanPath, ":") = 0 And Left(cleanPath, 2) <> "\\" Then cleanPath = CurrentProject.path & "\" & cleanPath
    If Left(cleanPath, 1) = ":" Then cleanPath = CurrentProject.path & "\" & cleanPath

    ' تصحيح الأخطاء في كتابة المسارات
    cleanPath = Replace(cleanPath, "\:\", "\\")
    cleanPath = Replace(cleanPath, "\::\", "\")
    cleanPath = Replace(cleanPath, "\:", "\")

    ' استبدال \\ بـ \ باستثناء مسارات الشبكة \\Server\Share
    If Left(cleanPath, 2) <> "\\" Then cleanPath = Replace(cleanPath, "\\", "\")

    ' إرجاع المسار النظيف
    BuildFullPath = cleanPath
End Function

' إنشاء مجلدات بناءً على قائمة مسارات فرعية
Public Function CreateFolders(basePath As String, ParamArray folderPaths() As Variant) As String
    On Error GoTo ErrorHandler
    Dim path As Variant
    Dim fullPath As String
    Dim errorMessage As String
    
    InitializeFSO
    
    ' التحقق من وجود المسار الأساسي وإنشاؤه إذا لم يكن موجودًا
    If Not FolderExists(basePath) Then
        CreateFolderStructure basePath, errorMessage
        If errorMessage <> "" Then
            CreateFolders = errorMessage
            Exit Function
        End If
    End If
    
    ' إنشاء المسارات الفرعية
    For Each path In folderPaths
        fullPath = BuildPath(basePath, CStr(path))
        If Not CreateFolderStructure(fullPath, errorMessage) Then
            CreateFolders = errorMessage
            Exit Function
        End If
    Next
    
    CreateFolders = "Success"
    Exit Function
    
ErrorHandler:
    CreateFolders = "خطأ " & Err.Number & ": " & Err.Description
End Function

' إنشاء مجلدات بناءً على بيانات جدول في قاعدة البيانات
Public Function CreateFoldersFromTable(tableName As String, basePathField As String, Optional condition As String = "") As String
    On Error GoTo ErrorHandler
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim query As String
    Dim basePath As String
    Dim folderPath As String
    Dim errorMessage As String
    
    Set db = CurrentDb()
    ' بناء استعلام لاستخراج المسارات الفريدة
    query = "SELECT DISTINCT [" & basePathField & "] FROM [" & tableName & "]"
    If condition <> "" Then query = query & " WHERE " & condition
    
    Set rs = db.OpenRecordset(query, dbOpenSnapshot)
    
    ' التحقق من وجود سجلات
    If rs.BOF And rs.EOF Then
        CreateFoldersFromTable = "لا توجد سجلات."
        Exit Function
    End If
    
    ' إنشاء المجلدات لكل سجل
    Do While Not rs.EOF
        basePath = Nz(rs.Fields(basePathField).Value, "")
        folderPath = BuildFullPath(basePath)
        
        ' التحقق من صحة المسار وإنشاؤه
        If Not CreateFolderStructure(folderPath, errorMessage) Then
            CreateFoldersFromTable = errorMessage
            Exit Function
        End If
        
        rs.MoveNext
    Loop
    
    ' إغلاق السجلات وتنظيف الذاكرة
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    
    CreateFoldersFromTable = "Success"
    Exit Function
    
ErrorHandler:
    CreateFoldersFromTable = "خطأ " & Err.Number & ": " & Err.Description
End Function

 

ويتم الاستدعاء حسب خيال المبرمج وهذه امثله لصور الاستدعاء

' إنشاء مجلدات يدويا ً من خلال تمرير المسار
Sub Example1()
    Dim result As String
    result = CreateFolders("C:\Project Resources", _
        "Backup", _
        "Fonts\Arabic", _
        "Fonts\English", _
        "Images\Ico", _
        "Images\Logo", _
        "Images\QR Code", _
        "PDF", _
        "Utility\Reference\MsAccess", _
        "Utility\Reference\TBL")
    
    If result = "Success" Then
        MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation
    Else
        MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical
    End If
End Sub

' إنشاء مجلدات داخل مشروع Access الحالي
Sub Example2()
    Dim result As String
    result = CreateFolders(CurrentProject.path & "\Project Resources", _
        "Backup", _
        "Fonts\Arabic", _
        "Fonts\English", _
        "Images\Ico", _
        "Images\Logo", _
        "Images\QR Code", _
        "PDF", _
        "Utility\Reference\MsAccess", _
        "Utility\Reference\TBL")
    
    If result = "Success" Then
        MsgBox "تم إنشاء المجلدات داخل مشروع Access!", vbInformation
    Else
        MsgBox "حدث خطأ أثناء إنشاء المجلدات: " & result, vbCritical
    End If
End Sub

' إنشاء مجلدات من جدول في قاعدة البيانات
Sub Example3()
    Dim result As String
    result = CreateFoldersFromTable("tblFolderPaths", "FolderPath")
    
    If result = "Success" Then
        MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation
    Else
        MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical
    End If
End Sub

' إنشاء مجلدات بناءً على فئة معينة
Sub Example4()
    Dim result As String
    result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = 'Access'")
    
    If result = "Success" Then
        MsgBox "تم إنشاء المجلدات الخاصة بمكتبات Access!", vbInformation
    Else
        MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical
    End If
End Sub

' إنشاء مجلدات شبكة (UNC Paths)
Sub Example5()
    Dim result As String
    result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath")
    
    If result = "Success" Then
        MsgBox "تم إنشاء المجلدات الشبكية بنجاح!", vbInformation
    Else
        MsgBox "حدث خطأ أثناء إنشاء المجلدات الشبكية: " & result, vbCritical
    End If
End Sub

' إنشاء مجلدات شبكة بناءً على خادم معين
Sub Example6()
    Dim result As String
    result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath", "Server = 'FileServer01'")
    
    If result = "Success" Then
        MsgBox "تم إنشاء المجلدات على FileServer01!", vbInformation
    Else
        MsgBox "فشل في العثور على مجلدات لهذا الخادم: " & result, vbCritical
    End If
End Sub

' إنشاء مجلدات بناءً على مدخلات المستخدم
Sub Example7()
    Dim userCategory As String
    userCategory = InputBox("أدخل اسم الفئة لإنشاء المجلدات:", "تحديد الفئة")
    
    If userCategory <> "" Then
        Dim result As String
        result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = '" & userCategory & "'")
        
        If result = "Success" Then
            MsgBox "تم إنشاء المجلدات للفئة: " & userCategory, vbInformation
        Else
            MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical
        End If
    Else
        MsgBox "لم يتم إدخال فئة صحيحة!", vbExclamation
    End If
End Sub

الهدف: إنشاء مجلدات ديناميكيًا في مسار أساسي باستخدام معلومات مدخلة يدوية أو مستخلصة من قاعدة بيانات
 

 

الحالات المختلفة للاستدعاء:

• الحالة 1: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار 
• الحالة 2: استدعاء دالة لإنشاء مجلد /هيكل المجلدات في مجلد مشروع Access الحالي
• الحالة 3: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول قاعدة بيانات
• الحالة 4: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول مع تصفية حسب فئة معينة
• الحالة 5: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار الشبكي(UNC)  
• الحالة 6: استدعاء دالة لإنشاء المجلدات من خلال مسارات من جدول مع تصفية حسب اسم الخادم المستخدم للمسار الشبكي (UNC)  

 

انشاء مجلد او هيكل مجلدات.zip

[Foksh]

ما شاء الله ، الله يعطيك العافية مهندسنا @ابو جودي ..  ..

اسمح لي بسؤال بسيط لولبي  ..

  هل تمت التجربة على اضافة مسارات على جهاز آخر في الشبكة ؟؟؟؟؟؟؟؟؟؟؟؟؟

 

 

[ابو جودي]

39 دقائق مضت, Foksh said:

ما شاء الله ، الله يعطيك العافية مهندسنا @ابو جودي ..  ..

اسمح لي بسؤال بسيط لولبي  ..

  هل تمت التجربة على اضافة مسارات على جهاز آخر في الشبكة ؟؟؟؟؟؟؟؟؟؟؟؟؟

 

 

نعم ولكن طبعا يلزم صلاحيات لذلك فى وجود الصلاحيات كل شئ تمام