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

[ابو جودي]

انشاء مجلد واحد او العديد من المجلدات دفعة واحدة

 

CreateMultiFolders.mdb

[walid7799]

زادك الله بالعلم النافع ووهب لك من لدنه رحمة وعلما والمسلمين والمسلمات والمؤمنين والمؤمنات وجمعنا واياهم على حوض نبينا وسيد ولد ادم ورزقنا الجنة دون حساب ولا سابقة عذاب

[walid7799]

هل يمكن شرح عمل الماكرو والكود للاستفادة

[ابو جودي]

اولا لابد من اضافة المكتبة الاتية

Microsoft Scripting Runtime

بدون اضافة المكتبة لن يعمل الكود 

طيب الكود الاتى فى المديول لانشاء المجلدات 

Option Compare Database
Option Explicit

'Requires reference
'set a reference >>---> Microsoft Scripting Runtime
    
#If Win64 Then
    Private Declare PtrSafe Function PathIsRelative Lib "Shlwapi" _
        Alias "PathIsRelativeA" (ByVal Path As String) As Long
#Else
    Private Declare Function PathIsRelative Lib "Shlwapi" _
        Alias "PathIsRelativeA" (ByVal Path As String) As Long
#End If
      
    Public Enum EMakeDirStatus
        ErrSuccess = 0
        ErrRelativePath
        ErrInvalidPathSpecification
        ErrDirectoryCreateError
        ErrSpecIsFileName
        ErrInvalidCharactersInPath
    End Enum
    Const MAX_PATH = 260
    
    Function MakeMultiStepDirectory(ByVal PathSpec As String) As EMakeDirStatus
    ''''''''''''''''''''''''''
    ' MakeMultiStepDirectory '
    ''''''''''''''''''''''''''
    Dim FSO As Scripting.FileSystemObject
    Dim DD As Scripting.Drive
    Dim B As Boolean
    Dim Root As String
    Dim DirSpec As String
    Dim N As Long
    Dim M As Long
    Dim S As String
    Dim Directories() As String
        
    Set FSO = New Scripting.FileSystemObject
        
    ' ensure there are no invalid characters in spec.
    On Error Resume Next
    Err.Clear
    S = Dir(PathSpec, vbNormal)
    If Err.Number <> 0 Then
        MakeMultiStepDirectory = ErrInvalidCharactersInPath
        Exit Function
    End If
    On Error GoTo 0
    
    ' ensure we have an absolute path
    B = CBool(PathIsRelative(PathSpec))
    If B = True Then
        MakeMultiStepDirectory = ErrRelativePath
        Exit Function
    End If
    
    ' if the directory already exists, get out with success.
    If FSO.FolderExists(PathSpec) = True Then
        MakeMultiStepDirectory = ErrSuccess
        Exit Function
    End If
    
    ' get rid of trailing slash
    If Right(PathSpec, 1) = "\" Then
        PathSpec = Left(PathSpec, Len(PathSpec) - 1)
    End If
    
    ' ensure we don't have a filename
    N = InStrRev(PathSpec, "\")
    M = InStrRev(PathSpec, ".")
    If (N > 0) And (M > 0) Then
        If M > N Then
            ' period found after last slash
            MakeMultiStepDirectory = ErrSpecIsFileName
            Exit Function
        End If
    End If
    
    If Left(PathSpec, 2) = "\\" Then
        ' UNC -> \\Server\Share\Folder...
        N = InStr(3, PathSpec, "\")
        N = InStr(N + 1, PathSpec, "\")
        Root = Left(PathSpec, N - 1)
        DirSpec = Mid(PathSpec, N + 1)
    Else
        ' Local or mapped -> C:\Folder....
        N = InStr(1, PathSpec, ":", vbBinaryCompare)
        If N = 0 Then
            MakeMultiStepDirectory = ErrInvalidPathSpecification
            Exit Function
        End If
        Root = Left(PathSpec, N)
        DirSpec = Mid(PathSpec, N + 2)
    End If
    Set DD = FSO.GetDrive(Root)
    Directories = Split(DirSpec, "\")
    DirSpec = DD.Path
    For N = LBound(Directories) To UBound(Directories)
        DirSpec = DirSpec & "\" & Directories(N)
        If FSO.FolderExists(DirSpec) = False Then
            On Error Resume Next
            Err.Clear
            FSO.CreateFolder (DirSpec)
            If Err.Number <> 0 Then
                MakeMultiStepDirectory = ErrDirectoryCreateError
                Exit Function
            End If
        End If
    Next N
    MakeMultiStepDirectory = ErrSuccess
    End Function

وتسهيلا ولاضفاء مرونة فى الاستخدام قمت بكتابة الروتين الاتى ليتم استخدامة هو فقط 

Public Function MD(strPathDr) As EMakeDirStatus
  MD = MakeMultiStepDirectory(strPathDr)
End Function

يتم استدعاء الروتين من خلال 

 MD(***)

مع تغيير الـ *** بالمسار للمجلدات
على سبيل المثال لو اردنا عمل مجلد فى القطاع  D   على ان يكون اسمه  Officena
ونريد بداخله مجلد باسم Access 
ونريد بجوار المجلد  Access   مجلد باسم  Moh3sam  وبداخلة مجلد باسم Judy
وبداخل مجلد مجلد Access مجلد باسم  VBA

يكون الكود كالأتى

MD("D:\Officena\Access\VBA")
MD("D:\Officena\Moh3sam\Judy")

 

[walid7799]

شكرا لاخى الكريم ذادك الله من كرمه كرما اخلاقا وعلما وصبرا واثابك به حسن الثواب في الدنيا والاخرة ونفع بك

[د.كاف يار]

ما شاء الله عليك مبدع و عجبتني هذي الرسمة ماشاء الله تبارك الرحمن

[walid7799]

ولاكن يكون تحديد المسار برمجيا ولا يتيح اختيار مكان من المستخدم هل يمكن ان نطلق العنان والاتاحة لاختيار الاماكن

اللهم ارضنا وارض عنا

[ابو جودي]

41 دقائق مضت, walid7799 said:

ولا يتيح اختيار مكان من المستخدم هل يمكن ان نطلق العنان والاتاحة لاختيار الاماكن

جرب الاتى ولاخظ انك تختار اسم ومكان كل مجلد تحديدا حتى لو 100 مجلد او اكثر 

MD("D:\Officena\Access\VBA\a\b\c\d\e\f\g\h")
MD("D:\Officena\Access\VBA\1\2\3\4\5\6\7\8")

لو تقصد لازم التعديل من الكود فقط اقول لك لا

اعمل جدول واعمل الدالة DLookup لتكون بذلك الشكل

MD(DLookup("[FldName]","tblName"))

وفى الجدول اكتب المسار الذى تريده 

طبعا ممكن تعمل معيار للدالة لاختيار حقل محدد

وتسطيع عمل loop  على كل سجلات الجدول لينشئ كل المجلدات بجانب او داخل بعضها او فى اماكن متفرقة دفعة واحدة بضغطة زر

اذا كيف لا يتيح مرونة