اذهب الي المحتوي
أوفيسنا

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

hanan_ms

بواسطه hanan_ms
في قسم الأكسيس Access

 مشاركة

الردود الموصى بها

ابو جودي

ابو جودي

قام بنشر
قام بنشر

طيب لاحظت عند النقر على زر الامر الخاص باختيار قاعدة البيانات انه يتم فتح مستعرض الملفات مرتين واختيار القاعدة مرتين مش غريبه دى :eek2:

Foksh

Foksh

قام بنشر
قام بنشر

قد اتطلعت مسبقاً على فكرة مشابهة ذات تفاصيل اكثر في موضوع تم نشره على أحد المنتديات الأجنبية هنا ..

FormLocalLinked.png.44a49235c64a74e6ec7adceb810b1d48.png

 

وقد كان لي تجربة شخصية في الموضوع التالي أيضاً:-

 

بشكل مختلف قليلاً من خلال عرض حجم قاعدة البيانات الحالية على شكل عداد

Metro-PC.png

 

  • Like 2
ابو جودي

ابو جودي

قام بنشر
قام بنشر

شوف يا فؤش خطر بالى كتابة الكود بالشكل التالى فى وحده نمطية عامة 

' تعداد لتحديد نوع العنصر
Public Enum fileType
    ftAccessDB = 1      ' قاعدة بيانات Access
    ftExcel = 2         ' ملف Excel
    ftWord = 3          ' ملف Word
    ftText = 4          ' ملف نصي
    ftFolder = 5        ' مجلد
    ftDrive = 6         ' قسم (Drive)
    ftAnyFile = 7       ' أي ملف
End Enum

' تعداد لتحديد نوع المعلومات المطلوبة
Public Enum infoType
    itPathOnly = 1      ' جلب المسار فقط
    itSizeOnly = 2      ' جلب الحجم فقط
    itPathAndSize = 3   ' جلب المسار والحجم
    itFileNameOnly = 4  ' جلب اسم الملف فقط
    itFileExtension = 5 ' جلب امتداد الملف فقط
    itFileNameAndExt = 6 ' جلب اسم الملف مع الامتداد
    itCreationDate = 7  ' جلب تاريخ الإنشاء
    itModifiedDate = 8  ' جلب تاريخ التعديل
    itFileCount = 9     ' جلب عدد الملفات (لمجلد)
    itFreeSpace = 10    ' جلب المساحة الحرة (لقسم)
    itTotalSpace = 11   ' جلب المساحة الإجمالية (لقسم)
    itDriveType = 12    ' جلب نوع القسم
    itParentPath = 13   ' جلب المسار الأصلي
End Enum

' تعداد لتحديد الامتدادات
Public Enum FileExtension
    feAccessDB = 1      ' *.accdb;*.mdb
    feExcel = 2         ' *.xlsx;*.xls
    feWord = 3          ' *.docx;*.doc
    feText = 4          ' *.txt
    feAnyFile = 7       ' *.*
End Enum

' دالة مساعدة للحصول على وصف وامتداد بناءً على FileType
Private Function GetFileFilter(fileType As fileType) As Variant
    Dim description As String
    Dim extension As String
    
    Select Case fileType
        Case ftAccessDB
            description = "قواعد بيانات Access"
            extension = "*.accdb;*.mdb"
        Case ftExcel
            description = "ملفات Excel"
            extension = "*.xlsx;*.xls"
        Case ftWord
            description = "ملفات Word"
            extension = "*.docx;*.doc"
        Case ftText
            description = "ملفات نصية"
            extension = "*.txt"
        Case ftAnyFile
            description = "كل الملفات"
            extension = "*.*"
        Case Else
            description = vbNullString
            extension = vbNullString
    End Select
    
    GetFileFilter = Array(description, extension)
End Function

' دالة رئيسية للحصول على معلومات العنصر
Public Function GetFileInfo(Optional inputPath As String = vbNullString, _
                           Optional txtPath As TextBox = Nothing, _
                           Optional txtSize As TextBox = Nothing, _
                           Optional txtName As TextBox = Nothing, _
                           Optional txtExt As TextBox = Nothing, _
                           Optional txtExtra As TextBox = Nothing, _
                           Optional fileType As fileType = ftAccessDB, _
                           Optional infoType As infoType = itPathAndSize, _
                           Optional decimalPlaces As Integer = 2) As String
    On Error GoTo ErrorHandler
    
    Dim fso As Object
    Dim shellApp As Object
    Dim dbPath As String
    Dim totalSize As Double
    Dim fileName As String
    Dim fileExt As String
    Dim formatStr As String
    
    ' إعداد تنسيق الحجم
    formatStr = "0." & String(decimalPlaces, "0")
    
    ' إنشاء كائن FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' التحقق من المسار المدخل مباشرة فقط
    If Len(Trim(inputPath)) > 0 Then
        dbPath = inputPath
    Else
        ' إذا لم يتم تمرير inputPath، افتح المستعرض دائمًا
        Set shellApp = CreateObject("Shell.Application")
        
        Select Case fileType
            Case ftFolder
                Dim folder As Object
                Set folder = shellApp.BrowseForFolder(0, "اختر مجلدًا", 0)
                If Not folder Is Nothing Then
                    dbPath = folder.Self.path
                Else
                    GetFileInfo = "لم يتم اختيار مجلد"
                    Exit Function
                End If
                
            Case ftDrive
                Dim driveFolder As Object
                Set driveFolder = shellApp.BrowseForFolder(0, "اختر قسمًا", 0, 17) ' 17 = ssfDRIVES
                If Not driveFolder Is Nothing Then
                    dbPath = driveFolder.Self.path
                    If Right(dbPath, 1) <> "\" Then dbPath = dbPath & "\"
                Else
                    GetFileInfo = "لم يتم اختيار قسم"
                    Exit Function
                End If
                
            Case Else ' ملفات
                Dim fd As Object
                Set fd = Application.fileDialog(3) ' 3 = msoFileDialogFilePicker
                
                With fd
                    .Title = "اختر ملفًا"
                    .Filters.Clear
                    
                    Dim filter As Variant
                    filter = GetFileFilter(fileType)
                    If Len(filter(0)) > 0 Then
                        .Filters.Add filter(0), filter(1)
                    End If
                    
                    .AllowMultiSelect = False
                    If .Show = -1 Then
                        dbPath = .SelectedItems(1)
                    Else
                        GetFileInfo = "لم يتم اختيار ملف"
                        Exit Function
                    End If
                End With
        End Select
    End If
    
    ' التحقق من وجود العنصر
    If Not fso.FileExists(dbPath) And Not fso.FolderExists(dbPath) And Not fso.DriveExists(dbPath) Then
        GetFileInfo = "العنصر غير موجود"
        Exit Function
    End If
    
    ' استخراج المعلومات بناءً على infoType
    Select Case infoType
        Case itPathOnly
            If Not txtPath Is Nothing Then txtPath.Value = dbPath
            GetFileInfo = dbPath
            
        Case itSizeOnly
            totalSize = GetSize(fso, dbPath, fileType)
            Dim sizeStr As String
            sizeStr = FormatSize(totalSize, formatStr)
            If Not txtSize Is Nothing Then txtSize.Value = sizeStr
            GetFileInfo = sizeStr
            
        Case itPathAndSize
            totalSize = GetSize(fso, dbPath, fileType)
            sizeStr = FormatSize(totalSize, formatStr)
            If Not txtPath Is Nothing Then txtPath.Value = dbPath
            If Not txtSize Is Nothing Then txtSize.Value = sizeStr
            GetFileInfo = dbPath & " - " & sizeStr
            
        Case itFileNameOnly
            If fso.FileExists(dbPath) Then
                fileName = fso.GetBaseName(dbPath)
                If Not txtName Is Nothing Then txtName.Value = fileName
                GetFileInfo = fileName
            Else
                GetFileInfo = "المسار ليس ملفًا"
            End If
            
        Case itFileExtension
            If fso.FileExists(dbPath) Then
                fileExt = fso.GetExtensionName(dbPath)
                If Not txtExt Is Nothing Then txtExt.Value = fileExt
                GetFileInfo = fileExt
            Else
                GetFileInfo = "المسار ليس ملفًا"
            End If
            
        Case itFileNameAndExt
            If fso.FileExists(dbPath) Then
                fileName = fso.GetFileName(dbPath)
                If Not txtName Is Nothing Then txtName.Value = fileName
                GetFileInfo = fileName
            Else
                GetFileInfo = "المسار ليس ملفًا"
            End If
            
        Case itCreationDate
            If fso.FileExists(dbPath) Then
                GetFileInfo = fso.GetFile(dbPath).DateCreated
            ElseIf fso.FolderExists(dbPath) Then
                GetFileInfo = fso.GetFolder(dbPath).DateCreated
            ElseIf fso.DriveExists(dbPath) Then
                GetFileInfo = "غير متاح للأقسام"
            End If
            If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            
        Case itModifiedDate
            If fso.FileExists(dbPath) Then
                GetFileInfo = fso.GetFile(dbPath).DateLastModified
            ElseIf fso.FolderExists(dbPath) Then
                GetFileInfo = fso.GetFolder(dbPath).DateLastModified
            ElseIf fso.DriveExists(dbPath) Then
                GetFileInfo = "غير متاح للأقسام"
            End If
            If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            
        Case itFileCount
            If fso.FolderExists(dbPath) Then
                GetFileInfo = CStr(fso.GetFolder(dbPath).files.Count)
                If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            Else
                GetFileInfo = "المسار ليس مجلدًا"
            End If
            
        Case itFreeSpace
            If fso.DriveExists(dbPath) Then
                totalSize = fso.GetDrive(fso.GetDriveName(dbPath)).FreeSpace
                sizeStr = FormatSize(totalSize, formatStr)
                If Not txtSize Is Nothing Then txtSize.Value = sizeStr
                GetFileInfo = sizeStr
            Else
                GetFileInfo = "المسار ليس قسمًا"
            End If
            
        Case itTotalSpace
            If fso.DriveExists(dbPath) Then
                totalSize = fso.GetDrive(fso.GetDriveName(dbPath)).totalSize
                sizeStr = FormatSize(totalSize, formatStr)
                If Not txtSize Is Nothing Then txtSize.Value = sizeStr
                GetFileInfo = sizeStr
            Else
                GetFileInfo = "المسار ليس قسمًا"
            End If
            
        Case itDriveType
            If fso.DriveExists(dbPath) Then
                Select Case fso.GetDrive(fso.GetDriveName(dbPath)).FileSystem
                    Case "FAT", "FAT32", "NTFS", "exFAT"
                        GetFileInfo = fso.GetDrive(fso.GetDriveName(dbPath)).FileSystem
                    Case Else
                        GetFileInfo = "غير معروف"
                End Select
                If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            Else
                GetFileInfo = "المسار ليس قسمًا"
            End If
            
        Case itParentPath
            If fso.FileExists(dbPath) Then
                GetFileInfo = fso.GetParentFolderName(dbPath)
            ElseIf fso.FolderExists(dbPath) Then
                GetFileInfo = fso.GetParentFolderName(dbPath)
            ElseIf fso.DriveExists(dbPath) Then
                GetFileInfo = "لا يوجد مسار أصلي للقسم"
            End If
            If Not txtPath Is Nothing Then txtPath.Value = GetFileInfo
    End Select
    
    Exit Function
    
ErrorHandler:
    GetFileInfo = "حدث خطأ (" & Err.Number & "): " & Err.description
    If Not fso Is Nothing Then Set fso = Nothing
    If Not shellApp Is Nothing Then Set shellApp = Nothing
End Function

' دالة مساعدة لحساب الحجم
Private Function GetSize(fso As Object, path As String, fileType As fileType) As Double
    Select Case fileType
        Case ftAccessDB, ftExcel, ftWord, ftText, ftAnyFile
            If fso.FileExists(path) Then
                GetSize = fso.GetFile(path).size
            End If
        Case ftFolder
            If fso.FolderExists(path) Then
                GetSize = GetFolderSize(fso.GetFolder(path))
            End If
        Case ftDrive
            If fso.DriveExists(path) Then
                With fso.GetDrive(fso.GetDriveName(path))
                    GetSize = .totalSize - .FreeSpace
                End With
            End If
    End Select
End Function

' دالة مساعدة لتنسيق الحجم
Private Function FormatSize(size As Double, formatStr As String) As String
    If size < 1024 Then
        FormatSize = Format(size, formatStr) & " بايت"
    ElseIf size < 1024 ^ 2 Then
        FormatSize = Format(size / 1024, formatStr) & " كيلوبايت"
    ElseIf size < 1024 ^ 3 Then
        FormatSize = Format(size / (1024 ^ 2), formatStr) & " ميجابايت"
    Else
        FormatSize = Format(size / (1024 ^ 3), formatStr) & " جيجابايت"
    End If
End Function

' دالة مساعدة لحساب حجم المجلد
Private Function GetFolderSize(fld As Object) As Double
    On Error Resume Next
    Dim subFld As Object
    Dim file As Object
    Dim totalSize As Double
    
    For Each file In fld.files
        totalSize = totalSize + file.size
    Next file
    
    For Each subFld In fld.SubFolders
        totalSize = totalSize + GetFolderSize(subFld)
    Next subFld
    
    GetFolderSize = totalSize
End Function

 

 

 

 

 

  • Like 1
Foksh

Foksh

قام بنشر
قام بنشر (معدل)
9 ساعات مضت, ابو جودي said:

شوف يا فؤش خطر بالى كتابة الكود بالشكل التالى فى وحده نمطية عامة 

' تعداد لتحديد نوع العنصر
Public Enum fileType
    ftAccessDB = 1      ' قاعدة بيانات Access
    ftExcel = 2         ' ملف Excel
    ftWord = 3          ' ملف Word
    ftText = 4          ' ملف نصي
    ftFolder = 5        ' مجلد
    ftDrive = 6         ' قسم (Drive)
    ftAnyFile = 7       ' أي ملف
End Enum

' تعداد لتحديد نوع المعلومات المطلوبة
Public Enum infoType
    itPathOnly = 1      ' جلب المسار فقط
    itSizeOnly = 2      ' جلب الحجم فقط
    itPathAndSize = 3   ' جلب المسار والحجم
    itFileNameOnly = 4  ' جلب اسم الملف فقط
    itFileExtension = 5 ' جلب امتداد الملف فقط
    itFileNameAndExt = 6 ' جلب اسم الملف مع الامتداد
    itCreationDate = 7  ' جلب تاريخ الإنشاء
    itModifiedDate = 8  ' جلب تاريخ التعديل
    itFileCount = 9     ' جلب عدد الملفات (لمجلد)
    itFreeSpace = 10    ' جلب المساحة الحرة (لقسم)
    itTotalSpace = 11   ' جلب المساحة الإجمالية (لقسم)
    itDriveType = 12    ' جلب نوع القسم
    itParentPath = 13   ' جلب المسار الأصلي
End Enum

' تعداد لتحديد الامتدادات
Public Enum FileExtension
    feAccessDB = 1      ' *.accdb;*.mdb
    feExcel = 2         ' *.xlsx;*.xls
    feWord = 3          ' *.docx;*.doc
    feText = 4          ' *.txt
    feAnyFile = 7       ' *.*
End Enum

' دالة مساعدة للحصول على وصف وامتداد بناءً على FileType
Private Function GetFileFilter(fileType As fileType) As Variant
    Dim description As String
    Dim extension As String
    
    Select Case fileType
        Case ftAccessDB
            description = "قواعد بيانات Access"
            extension = "*.accdb;*.mdb"
        Case ftExcel
            description = "ملفات Excel"
            extension = "*.xlsx;*.xls"
        Case ftWord
            description = "ملفات Word"
            extension = "*.docx;*.doc"
        Case ftText
            description = "ملفات نصية"
            extension = "*.txt"
        Case ftAnyFile
            description = "كل الملفات"
            extension = "*.*"
        Case Else
            description = vbNullString
            extension = vbNullString
    End Select
    
    GetFileFilter = Array(description, extension)
End Function

' دالة رئيسية للحصول على معلومات العنصر
Public Function GetFileInfo(Optional inputPath As String = vbNullString, _
                           Optional txtPath As TextBox = Nothing, _
                           Optional txtSize As TextBox = Nothing, _
                           Optional txtName As TextBox = Nothing, _
                           Optional txtExt As TextBox = Nothing, _
                           Optional txtExtra As TextBox = Nothing, _
                           Optional fileType As fileType = ftAccessDB, _
                           Optional infoType As infoType = itPathAndSize, _
                           Optional decimalPlaces As Integer = 2) As String
    On Error GoTo ErrorHandler
    
    Dim fso As Object
    Dim shellApp As Object
    Dim dbPath As String
    Dim totalSize As Double
    Dim fileName As String
    Dim fileExt As String
    Dim formatStr As String
    
    ' إعداد تنسيق الحجم
    formatStr = "0." & String(decimalPlaces, "0")
    
    ' إنشاء كائن FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' التحقق من المسار المدخل مباشرة فقط
    If Len(Trim(inputPath)) > 0 Then
        dbPath = inputPath
    Else
        ' إذا لم يتم تمرير inputPath، افتح المستعرض دائمًا
        Set shellApp = CreateObject("Shell.Application")
        
        Select Case fileType
            Case ftFolder
                Dim folder As Object
                Set folder = shellApp.BrowseForFolder(0, "اختر مجلدًا", 0)
                If Not folder Is Nothing Then
                    dbPath = folder.Self.path
                Else
                    GetFileInfo = "لم يتم اختيار مجلد"
                    Exit Function
                End If
                
            Case ftDrive
                Dim driveFolder As Object
                Set driveFolder = shellApp.BrowseForFolder(0, "اختر قسمًا", 0, 17) ' 17 = ssfDRIVES
                If Not driveFolder Is Nothing Then
                    dbPath = driveFolder.Self.path
                    If Right(dbPath, 1) <> "\" Then dbPath = dbPath & "\"
                Else
                    GetFileInfo = "لم يتم اختيار قسم"
                    Exit Function
                End If
                
            Case Else ' ملفات
                Dim fd As Object
                Set fd = Application.fileDialog(3) ' 3 = msoFileDialogFilePicker
                
                With fd
                    .Title = "اختر ملفًا"
                    .Filters.Clear
                    
                    Dim filter As Variant
                    filter = GetFileFilter(fileType)
                    If Len(filter(0)) > 0 Then
                        .Filters.Add filter(0), filter(1)
                    End If
                    
                    .AllowMultiSelect = False
                    If .Show = -1 Then
                        dbPath = .SelectedItems(1)
                    Else
                        GetFileInfo = "لم يتم اختيار ملف"
                        Exit Function
                    End If
                End With
        End Select
    End If
    
    ' التحقق من وجود العنصر
    If Not fso.FileExists(dbPath) And Not fso.FolderExists(dbPath) And Not fso.DriveExists(dbPath) Then
        GetFileInfo = "العنصر غير موجود"
        Exit Function
    End If
    
    ' استخراج المعلومات بناءً على infoType
    Select Case infoType
        Case itPathOnly
            If Not txtPath Is Nothing Then txtPath.Value = dbPath
            GetFileInfo = dbPath
            
        Case itSizeOnly
            totalSize = GetSize(fso, dbPath, fileType)
            Dim sizeStr As String
            sizeStr = FormatSize(totalSize, formatStr)
            If Not txtSize Is Nothing Then txtSize.Value = sizeStr
            GetFileInfo = sizeStr
            
        Case itPathAndSize
            totalSize = GetSize(fso, dbPath, fileType)
            sizeStr = FormatSize(totalSize, formatStr)
            If Not txtPath Is Nothing Then txtPath.Value = dbPath
            If Not txtSize Is Nothing Then txtSize.Value = sizeStr
            GetFileInfo = dbPath & " - " & sizeStr
            
        Case itFileNameOnly
            If fso.FileExists(dbPath) Then
                fileName = fso.GetBaseName(dbPath)
                If Not txtName Is Nothing Then txtName.Value = fileName
                GetFileInfo = fileName
            Else
                GetFileInfo = "المسار ليس ملفًا"
            End If
            
        Case itFileExtension
            If fso.FileExists(dbPath) Then
                fileExt = fso.GetExtensionName(dbPath)
                If Not txtExt Is Nothing Then txtExt.Value = fileExt
                GetFileInfo = fileExt
            Else
                GetFileInfo = "المسار ليس ملفًا"
            End If
            
        Case itFileNameAndExt
            If fso.FileExists(dbPath) Then
                fileName = fso.GetFileName(dbPath)
                If Not txtName Is Nothing Then txtName.Value = fileName
                GetFileInfo = fileName
            Else
                GetFileInfo = "المسار ليس ملفًا"
            End If
            
        Case itCreationDate
            If fso.FileExists(dbPath) Then
                GetFileInfo = fso.GetFile(dbPath).DateCreated
            ElseIf fso.FolderExists(dbPath) Then
                GetFileInfo = fso.GetFolder(dbPath).DateCreated
            ElseIf fso.DriveExists(dbPath) Then
                GetFileInfo = "غير متاح للأقسام"
            End If
            If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            
        Case itModifiedDate
            If fso.FileExists(dbPath) Then
                GetFileInfo = fso.GetFile(dbPath).DateLastModified
            ElseIf fso.FolderExists(dbPath) Then
                GetFileInfo = fso.GetFolder(dbPath).DateLastModified
            ElseIf fso.DriveExists(dbPath) Then
                GetFileInfo = "غير متاح للأقسام"
            End If
            If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            
        Case itFileCount
            If fso.FolderExists(dbPath) Then
                GetFileInfo = CStr(fso.GetFolder(dbPath).files.Count)
                If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            Else
                GetFileInfo = "المسار ليس مجلدًا"
            End If
            
        Case itFreeSpace
            If fso.DriveExists(dbPath) Then
                totalSize = fso.GetDrive(fso.GetDriveName(dbPath)).FreeSpace
                sizeStr = FormatSize(totalSize, formatStr)
                If Not txtSize Is Nothing Then txtSize.Value = sizeStr
                GetFileInfo = sizeStr
            Else
                GetFileInfo = "المسار ليس قسمًا"
            End If
            
        Case itTotalSpace
            If fso.DriveExists(dbPath) Then
                totalSize = fso.GetDrive(fso.GetDriveName(dbPath)).totalSize
                sizeStr = FormatSize(totalSize, formatStr)
                If Not txtSize Is Nothing Then txtSize.Value = sizeStr
                GetFileInfo = sizeStr
            Else
                GetFileInfo = "المسار ليس قسمًا"
            End If
            
        Case itDriveType
            If fso.DriveExists(dbPath) Then
                Select Case fso.GetDrive(fso.GetDriveName(dbPath)).FileSystem
                    Case "FAT", "FAT32", "NTFS", "exFAT"
                        GetFileInfo = fso.GetDrive(fso.GetDriveName(dbPath)).FileSystem
                    Case Else
                        GetFileInfo = "غير معروف"
                End Select
                If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo
            Else
                GetFileInfo = "المسار ليس قسمًا"
            End If
            
        Case itParentPath
            If fso.FileExists(dbPath) Then
                GetFileInfo = fso.GetParentFolderName(dbPath)
            ElseIf fso.FolderExists(dbPath) Then
                GetFileInfo = fso.GetParentFolderName(dbPath)
            ElseIf fso.DriveExists(dbPath) Then
                GetFileInfo = "لا يوجد مسار أصلي للقسم"
            End If
            If Not txtPath Is Nothing Then txtPath.Value = GetFileInfo
    End Select
    
    Exit Function
    
ErrorHandler:
    GetFileInfo = "حدث خطأ (" & Err.Number & "): " & Err.description
    If Not fso Is Nothing Then Set fso = Nothing
    If Not shellApp Is Nothing Then Set shellApp = Nothing
End Function

' دالة مساعدة لحساب الحجم
Private Function GetSize(fso As Object, path As String, fileType As fileType) As Double
    Select Case fileType
        Case ftAccessDB, ftExcel, ftWord, ftText, ftAnyFile
            If fso.FileExists(path) Then
                GetSize = fso.GetFile(path).size
            End If
        Case ftFolder
            If fso.FolderExists(path) Then
                GetSize = GetFolderSize(fso.GetFolder(path))
            End If
        Case ftDrive
            If fso.DriveExists(path) Then
                With fso.GetDrive(fso.GetDriveName(path))
                    GetSize = .totalSize - .FreeSpace
                End With
            End If
    End Select
End Function

' دالة مساعدة لتنسيق الحجم
Private Function FormatSize(size As Double, formatStr As String) As String
    If size < 1024 Then
        FormatSize = Format(size, formatStr) & " بايت"
    ElseIf size < 1024 ^ 2 Then
        FormatSize = Format(size / 1024, formatStr) & " كيلوبايت"
    ElseIf size < 1024 ^ 3 Then
        FormatSize = Format(size / (1024 ^ 2), formatStr) & " ميجابايت"
    Else
        FormatSize = Format(size / (1024 ^ 3), formatStr) & " جيجابايت"
    End If
End Function

' دالة مساعدة لحساب حجم المجلد
Private Function GetFolderSize(fld As Object) As Double
    On Error Resume Next
    Dim subFld As Object
    Dim file As Object
    Dim totalSize As Double
    
    For Each file In fld.files
        totalSize = totalSize + file.size
    Next file
    
    For Each subFld In fld.SubFolders
        totalSize = totalSize + GetFolderSize(subFld)
    Next subFld
    
    GetFolderSize = totalSize
End Function

 

 

 

 

 

فكرة الكود جميلة ، ولا بأس بها ، سلمت على الفكرة :signthankspin: .

لي تعقيب واحد على ما أظن من خلال قراءة الكود ...

في الجزء التالي :- 

    For Each subFld In fld.SubFolders
        totalSize = totalSize + GetFolderSize(subFld)
    Next subFld

يتم حجز مساحة في الذاكرة بشكل رهيب جداً ومتكرر بسبب تكرار الإستدعاء = For Each ، وخصوصاً مع المجلدات الكبيرة الحجم !!!

وبالتالي سيكون الأداء بطيء جداً :blink: عند الإفتراض أن مجلد رئيسي يحتوي 10 مجلدات فرعية - على سبيل المثال - ونريد جلب حجم هذا المجلد ، فأن الكود سيقوم بتخزين الأمر مكرراً 10 مرات في الذاكرة وبالتالي قد ينتج عنه أخطاء إما في جلب البيانات ( حجم المجلد ) أو عدم دقتها ، أو سينتج الخطأ Overflow في نهاية المطاف .

كما أنها لا تدعم الإيقاف أو ( ايقاف العملية ) وبالتالي قد تستمر العملية لوقت طويل دون تحكم :rol: .

 

وهذه بالنسبة لي الطريقتين التي فهمتهما لاستدعاء الدوال في الكود الذي اقترحته .. 

'مثال على مسار مجلد محدد في الكود
Sub ExampleGetFolderSize()
    Dim folderPath As String
    Dim result As String
    folderPath = "C:\Intel"
    result = GetFileInfo( _
        inputPath:=folderPath, _
        fileType:=ftFolder, _
        infoType:=itSizeOnly, _
        decimalPlaces:=2 _
    )
    MsgBox "حجم المجلد: " & result
End Sub


' مثال على استخدام مربع حوار لاختيار المجلد
Sub ExampleWithFolderPicker()
    Dim result As String
    result = GetFileInfo( _
        fileType:=ftFolder, _
        infoType:=itSizeOnly _
    )
    If result <> "لم يتم اختيار مجلد" Then
        MsgBox "حجم المجلد: " & result
    End If
End Sub

 

هذا من وجهة نظري ، ولا أحاول الخروج عن سياق الموضوع :wub: .

 

 

تم تعديل بواسطه Foksh
  • Like 2
hanan_ms

hanan_ms

قام بنشر
  • الكاتب
قام بنشر

اهلا اهلا استاذي @ابو جودي ❤️🌹☕☕

اهلا استاذ @Foksh❤️🌹☕

استاذ @Foksh بدال تخلي الرسم ثلاثي من اقصى 2 جيجا الى حجم الملف برسم دائرة بيانية امخلينها عداد موتر الله يهداكم 😂

الافضل يكون الشغل اكثر احترافية

 

تحديث بتطبيق اداة MultiPage (AcitveX) متقدم :yes:

لا تنسى تفعيل المكتبات :wink2:

 

1- اختيار ملف مره وحده الى تيرابايت

2- اختيار مجلد الى تيرابايت

3- اكتب المسار لو كان بالجدول الى تيرابايت

4- ادوات تحكم وتصحيح الخطأ عند اعادة التصميم MultiPage

 

 ينقصني تعديل لقراءة حجم المجلد مو الملف 

  بص على الكود بسيط وجاري التعقيد :rol: 

Option Compare Database
Option Explicit

'_______________( المتغيرات العامة )___________________

Private LastProcessedPage As String  ' لتتبع آخر تبويب تم التعامل معه
Private LastClickTime As Date        ' لتحديد وقت آخر ضغط
Private Const CLICK_DELAY As Integer = 1  ' الحد الأدنى بين الضغطات (بالثواني)

' ثوابت الألوان
Private Const TAB_NORMAL As Long = 15921906    ' رمادي فاتح
Private Const TAB_ACTIVE As Long = 16777215    ' أبيض
Private Const TAB_TEXT As Long = 0             ' أسود
Private Const TAB_HOVER As Long = 14483455     ' أزرق فاتح
Private Const BG_COLOR As Long = 12566463      ' أزرق غامق للخلفية

Private Sub B0_Click()
    On Error GoTo ErrorHandler

If IsNull(Me.B0) Or Me.B0 = "" Then
ShowUserMessage "حدد نوع الخط ...( فارغ )", vbCritical
Exit Sub
End If

  With Me.MultiPage3
  .FontName = Me.B0
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub CH1_Click()
    On Error GoTo ErrorHandler

If IsNull(Me.CH1) Or Me.CH1 = "" Then
ShowUserMessage "حدد النمط من القائمة...( فارغ )", vbCritical
Exit Sub
End If

  With Me.MultiPage3
  If Me.CH1 = 1 Then
  UpdateActiveTab
  .Style = Me.CH1 '=======( Buttons1 ) - ( Tabs0 ) - (None) -"
  Else
  .Style = Me.CH1 '=======( Buttons1 ) - ( Tabs0 ) - (None) -"
  End If
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub Ch2_Click()
    On Error GoTo ErrorHandler

If IsNull(Me.Ch2) Or Me.Ch2 = "" Then
ShowUserMessage "حدد تغير الاتجاهات...( فارغ )", vbCritical
Exit Sub
End If

  With Me.MultiPage3
 .TabOrientation = Me.Ch2 '====(0)Top - (1)Buttm - (2)Right - (3)Left - "
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub Ch3_Click()
    On Error GoTo ErrorHandler

If IsNull(Me.Ch3) Or Me.Ch3 = "" Then
ShowUserMessage "حدد النمط من القائمة...( فارغ )", vbCritical
Exit Sub
End If

  With Me.MultiPage3
  .SpecialEffect = Me.Ch3
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub Color_2_Click()
On Error GoTo ErrorHandler

Me.cx3 = DialogColor(Me.cx3.BackColor)
If IsNull(Me.cx3) Or Me.cx3 = "" Then
Else
Me.pack2.BackColor = Me.cx3
  With Me.MultiPage3
  .ForeColor = Me.cx3
  End With

End If

  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub color_Click()
    On Error GoTo ErrorHandler

Me.cx2 = DialogColor(Me.cx2.BackColor)
If IsNull(Me.cx2) Or Me.cx2 = "" Then
Else
Me.Pack.BackColor = Me.cx2
End If

  With Me.MultiPage3
   .BackColor = Me.cx2 'COLOR_NORMAL
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub Form_Close()
'__________( اغلاق والحفظ تهيئة القائمة )____________

Call Menu_X_Click

End Sub

Private Sub Form_Load()
 ' تهيئة القيم الأولية
    LastProcessedPage = ""
Call Menu_X_Click
End Sub

Private Sub Form_Open(Cancel As Integer)
Me.h = Me.InsideHeight
Me.w = Me.InsideWidth
Me.z1 = 0
Me.z2 = 0
Me.z3 = 0
End Sub

Private Sub Menu_X_Click()
On Error Resume Next
    With Me.MultiPage3
        '.Parent = Page
        '.Caption = btnCaption
       ' .Left = Left
       ' .Top = Top
        .Width = 2000
        .Height = 7665
        .FontName = "Segoe UI"
        .FontBold = True
        .Font.size = 10
        '===================( Nurmail )
        .BackColor = rgb(260, 260, 260) 'COLOR_NORMAL
        .ForeColor = rgb(0, 0, 0)        ' black Color
        .BorderColor = rgb(220, 220, 220)
        .BorderShade = rgb(180, 180, 180)
       ' .BackColor = RGB(51, 153, 255)
       ' .ForeColor = RGB(149, 179, 215)
        .TabOrientation = 3 '====(0)Top - (1)Buttm - (2)Right - (3)Left - "
        .Style = 0 '=======( Buttons1 ) - ( Tabs0 ) - (None) -"
        .MultiRow = True
        .TabFixedWidth = 80
        .TabFixedHeight = 20
        .BorderStyle = fmBorderStyleSingle
       '.SpecialEffect = fmSpecialEffectFlat
        .SpecialEffect = fmSpecialEffectEtched
        .MousePointer = fmMousePointerCustom
       '.BackStyle = fmBackStyleOpaque
       '.OnClick = "[Event Procedure]"
      
       Exit Sub
    End With

End Sub

Private Sub MultiPage3_Change()
    On Error GoTo ErrorHandler
    
   '_________________( الحدث الرئيسي )__________________
    Dim currentPage As String
   ' currentPage = Me.MultiPage3.SelectedItem.Caption
    currentPage = CleanPageName(Me.MultiPage3.SelectedItem.Caption)
    
    '______________( التحقق من التكرار )___________
    
    If currentPage = LastProcessedPage Then Exit Sub
    
    If currentPage = LastProcessedPage And _
       DateDiff("s", LastClickTime, Now) < CLICK_DELAY Then
        Exit Sub
    End If
     '__________( معالجة الأوامر حسب الصفحة )________
    Select Case currentPage
'________________________________________________________________________
        Case "MsgboxTest1"
            MsgBox "جاري فتح لوحة العملاء...", vbInformation, Date
          '  Call X
'________________________________________________________________________

        Case "MsgboxTest2"
            ShowUserMessage "جاري تحميل قائمة المنتجات...", vbInformation
'________________________________________________________________________
            
        Case "selected_Folder"
        Dim DL As Office.fileDialog
        Dim sizeInfo                  As String

        Set DL = Application.fileDialog(msoFileDialogFolderPicker)
        If DL.Show Then
      
        Call GetSelected_Path_DatabaseSize(DL.SelectedItems(1))
        sizeInfo = GetSelected_Path_DatabaseSize(DL.SelectedItems(1))
        Me.size = sizeInfo
        End If
'________________________________________________________________________
        Case "Selected_File_db"
        Dim sizeInfox                  As String
        Dim path_x As String
        Dim DLX As Office.fileDialog
        Set DLX = Application.fileDialog(msoFileDialogFilePicker)
        If DLX.Show Then
        path_x = DLX.SelectedItems(1)
        Call GetSelected_Path_DatabaseSize(path_x)
        sizeInfox = GetSelected_Path_DatabaseSize(path_x)
        Me.F5 = sizeInfox
        End If
        Case Else
      ' يمكنك إضافة صفحات أخرى هنا
      End Select
    
 '____( تحديث السجل الأخير )____
 
 LastProcessedPage = currentPage
    
    Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"
End Sub

Private Sub sz_Click()
    On Error GoTo ErrorHandler

If IsNull(Me.sz) Or Me.sz = "" Then
ShowUserMessage "حدد حجم الخط ...( فارغ )", vbCritical
Exit Sub
End If

  With Me.MultiPage3
  .Font.size = Me.sz
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

'                    Private Sub sizedb_Click()
'                    Dim sizeInfo                   As String
'
'                    Call GetSelectedDatabaseSize
'
'                    sizeInfo = GetSelectedDatabaseSize()
'                     Me.size = sizeInfo
'
'                    End Sub

Private Sub xxx_Click()
Dim sizeInfo                  As String


                    If IsNull(Me.path) Or Me.path = "" Then
                    MsgBox " الرجاء كتابة مسار قاعدة البيانات ", vbExclamation
                    Exit Sub
                    End If
 
Call GetSelected_Path_DatabaseSize(Me.path)
  
  
  sizeInfo = GetSelected_Path_DatabaseSize(Me.path)
    Me.size_path = sizeInfo

End Sub
Private Sub UpdateActiveTab()
    On Error Resume Next
    Dim i As Integer
    With Me.MultiPage3
      '   إعادة تعيين جميع التبويبات
        For i = 0 To .Pages.Count - 1
        If Me.MultiPage3.SelectedItem.Caption = "page1" Then
                        .BackColor = TAB_ACTIVE
                .ForeColor = rgb(0, 0, 139)  ' أزرق غامق
                .FontBold = True
Else
            .Pages(i).BackColor = TAB_NORMAL
            .Pages(i).ForeColor = TAB_TEXT
            .Pages(i).FontBold = False
            End If
        Next i
        
     '    تمييز التبويب النشط
        If .Pages.Count > 0 Then
            With .Pages(.Value)
                .BackColor = TAB_ACTIVE
                .ForeColor = rgb(0, 0, 139)  ' أزرق غامق
                .FontBold = True
            End With
        End If
    End With
End Sub

'_______________( الدوال المساعدة )_________________

Private Function CleanPageName(rawName As String) As String
    ' تنظيف اسم الصفحة من أي إضافات
    CleanPageName = Replace(Replace(rawName, "\", ""), "/", "")
End Function

Private Sub ShowUserMessage(msg As String, iconType As VbMsgBoxStyle)
    ' عرض رسائل المستخدم بشكل منسق
    Dim msgText As String
    msgText = "System Notification" & vbCrLf & String(50, "?") & vbCrLf & msg
    
    MsgBox msgText, iconType + vbSystemModal, "نظام الإدارة"
End Sub

Private Sub X()
Dim i As Integer
With Me.MultiPage3
 For i = 0 To .Pages.Count - 1
        If Me.MultiPage3.SelectedItem.Index = i Then
        
                       ' .BackColor = TAB_ACTIVE
                .ForeColor = rgb(0, 0, 139)  ' أزرق غامق
                .FontBold = True
Else
         '   .Pages(i).BackColor = TAB_NORMAL
            .Pages(i).ForeColor = TAB_TEXT
            .Pages(i).FontBold = False
            End If
        Next i
End With
End Sub

Private Sub z1_Click()
    On Error GoTo ErrorHandler


  With Me.MultiPage3
  If Me.z1 = 0 Then
  .FontUnderline = False
  Else
  .FontUnderline = True
  End If
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub z2_Click()
    On Error GoTo ErrorHandler


  With Me.MultiPage3
  If Me.z2 = 0 Then
  .FontItalic = False
  Else
  .FontItalic = True
  End If
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

Private Sub z3_Click()
    On Error GoTo ErrorHandler


  With Me.MultiPage3
  If Me.z3 = 0 Then
  .FontBold = False
  Else
  .FontBold = True
  End If
  End With
  
      Exit Sub
    
ErrorHandler:
    MsgBox "حدث الخطأ: " & Err.Description, vbCritical, "رقم الخطأ"

End Sub

 

 

 

V1_GiveMe_File_Out_Size_File.rar

Foksh

Foksh

قام بنشر
قام بنشر
منذ ساعه, hanan_ms said:

استاذ @Foksh بدال تخلي الرسم ثلاثي من اقصى 2 جيجا الى حجم الملف برسم دائرة بيانية امخلينها عداد موتر الله يهداكم 😂

 

دعنا نرى إبداعاتك في هذه الفكرة ، علنا نستفيد من أفكارك 😉 

hanan_ms

hanan_ms

قام بنشر
  • الكاتب
قام بنشر

تفضل استاذ @Foksh 🌹❤️☕

تحديث :rol:

3 hours ago, Foksh said:

دعنا نرى إبداعاتك في هذه الفكرة ، علنا نستفيد من أفكارك 😉 

انت ما تحب المعقدين :yes:

 

1- اضافة سحب ملف باسم بالمسار بعدد ملفات الفرعية في الملف وحجم الملف

2- اضافة استخراجهم برسالة 

3- تغير طريقة مستعرض الملفات 

4- الرسم البياني بشكل الدائرة 

- فقط جدول :eek2: سهل للغاية

 

حاضرين باي خدمات :biggrin2:

 

V1.4_GiveMe_File_Out_Size_File.rar

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept