A7MD M7MD قام بنشر مارس 28, 2019 مشاركة قام بنشر مارس 28, 2019 سلام عليكم Private Declare Function PathIsRelative Lib "Shlwapi" _ Alias "PathIsRelativeA" (ByVal Path As String) As Long 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 ' This function creates a series of nested directories. The parent of ' every directory is create before a subdirectory is created, allowing a ' folder path specification of any number of directories (as long as the ' total length is less than MAX_PATH. ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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 You can then call this code from your own code as follows: Sub AAA() Dim Result As EMakeDirStatus Result = MakeMultiStepDirectory("C:\One\Two\Three\Four") If Result = ErrSuccess Then Debug.Print "Success" Else Debug.Print "Error" End If End Sub 1 رابط هذا التعليق شارك More sharing options...
ابوخليل قام بنشر مارس 28, 2019 مشاركة قام بنشر مارس 28, 2019 عليكم السلام هو فعلا يعمل على اكسس بامتياز 1 رابط هذا التعليق شارك More sharing options...
A7MD M7MD قام بنشر مارس 29, 2019 الكاتب مشاركة قام بنشر مارس 29, 2019 20 ساعات مضت, ابوخليل said: عليكم السلام هو فعلا يعمل على اكسس بامتياز طيب ممكن المثال اللى حضرتك جربته لانه ما اشتغل معى يمكن انا طبقته غلط رابط هذا التعليق شارك More sharing options...
A7MD M7MD قام بنشر مارس 29, 2019 الكاتب مشاركة قام بنشر مارس 29, 2019 هذه تجربتي test.mdb رابط هذا التعليق شارك More sharing options...
ابوخليل قام بنشر مارس 29, 2019 مشاركة قام بنشر مارس 29, 2019 تفضل test2.mdb 1 1 رابط هذا التعليق شارك More sharing options...
A7MD M7MD قام بنشر مارس 29, 2019 الكاتب مشاركة قام بنشر مارس 29, 2019 شكرا أستاذ أبو خليل بس ممكن توضح لى اذا تكرمت الفرق بين المرفق بتاع حضرتك اللى اشتغل والمرفق بتاعى اللى لم يشتغل رابط هذا التعليق شارك More sharing options...
ابوخليل قام بنشر مارس 29, 2019 مشاركة قام بنشر مارس 29, 2019 المرفق كان بحاجة الى مكتبة script runtime وتم اضافتها انظر : رابط هذا التعليق شارك More sharing options...
A7MD M7MD قام بنشر مارس 29, 2019 الكاتب مشاركة قام بنشر مارس 29, 2019 شكرا سيدى رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان