ملف ارشيف

[husain alhammadi]

Sub ListFilesInFolderWithHyperlink_Optimized_WithOptions()
    ' Declares variables for file system objects and Excel ranges.
    Dim FSO As Object
    Dim Folder As Object
    Dim File As Object
    Dim Rng As Range
    Dim FolderPath As String
    Dim LastRow As Long
    Dim UserChoice As Long
    
    ' Define the list of folder paths.
    Dim FolderPaths(1 To 3) As String
    FolderPaths(1) = "C:\Users\husain\OneDrive\سطح المكتب\ارشيف\كشف.xlsm"
    FolderPaths(2) = "C:\Users\husain\OneDrive\سطح المكتب\ارشيف\ملفات"
    FolderPaths(3) = "C:\Users\husain\OneDrive\سطح المكتب\ارشيف"

    ' Prompt the user to choose a folder.
    UserChoice = Application.InputBox(Prompt:="الرجاء اختيار المجلد المطلوب:" & vbCrLf & _
                                       "1: ملف كشف.xlsm" & vbCrLf & _
                                       "2: مجلد ملفات" & vbCrLf & _
                                       "3: مجلد ارشيف", _
                                       Title:="اختيار المجلد", Type:=1)

    ' Check if the user made a valid choice.
    If UserChoice >= 1 And UserChoice <= 3 Then
        ' Set the selected folder path.
        FolderPath = FolderPaths(UserChoice)
    Else
        MsgBox "تم إلغاء العملية أو اختيار غير صالح.", vbExclamation, "إلغاء"
        Exit Sub
    End If
    
    ' Set the worksheet to be used.
    With ThisWorkbook.ActiveSheet
        ' Clears any previous data and hyperlinks from the specified range.
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        If LastRow > 1 Then
            .Range("B2:B" & LastRow).ClearContents
        End If
        .Hyperlinks.Delete
        
        ' Create the FileSystemObject.
        Set FSO = CreateObject("Scripting.FileSystemObject")
        
        ' Check if the folder exists.
        If FSO.FolderExists(FolderPath) Then
            ' Get the folder object and set the starting cell.
            Set Folder = FSO.GetFolder(FolderPath)
            Set Rng = .Range("B2")
            
            ' Loop through each file in the folder and add a hyperlink.
            For Each File In Folder.Files
                .Hyperlinks.Add Anchor:=Rng, Address:=File.Path, TextToDisplay:=File.Name
                Set Rng = Rng.Offset(1, 0)
            Next File
            
            ' Loop through each subfolder and add a hyperlink.
            For Each Folder In Folder.SubFolders
                .Hyperlinks.Add Anchor:=Rng, Address:=Folder.Path, TextToDisplay:=Folder.Name
                Set Rng = Rng.Offset(1, 0)
            Next Folder
            
            ' Displays a success message.
            MsgBox "تمت إضافة أسماء جميع الملفات والمجلدات كروابط تشعبية بنجاح.", vbInformation, "عملية ناجحة"
        Else
            ' Displays an error message if the folder path is invalid.
            MsgBox "مسار المجلد غير موجود. يرجى التحقق من المسار.", vbCritical, "خطأ"
        End If
    End With
    
    ' Release objects from memory.
    Set FSO = Nothing
    Set Folder = Nothing
End Sub

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

ارجو من اخواتي خبراء تاكد من الكود المرفق و تعديلها و المطلوب 

1- عند اضافة في ملف (ملفات) يتم نقلها مباشرة الي ملف كشف مع ارتباط تشعبي

2- في حالة اضافة او تعديل في ملف (ملفات) يتم نقل التعديل مباشرة الي ملف كشف 

و جزاكم الله خيرا 

 

كشف.xlsm