نجوم المشاركات

فكرة الكود جميلة ، ولا بأس بها ، سلمت على الفكرة . لي تعقيب واحد على ما أظن من خلال قراءة الكود ... في الجزء التالي :- For Each subFld In fld.SubFolders totalSize = totalSize + GetFolderSize(subFld) Next subFld يتم حجز مساحة في الذاكرة بشكل رهيب جداً ومتكرر بسبب تكرار الإستدعاء = For Each ، وخصوصاً مع المجلدات الكبيرة الحجم !!! وبالتالي سيكون الأداء بطيء جداً عند الإفتراض أن مجلد رئيسي يحتوي 10 مجلدات فرعية - على سبيل المثال - ونريد جلب حجم هذا المجلد ، فأن الكود سيقوم بتخزين الأمر مكرراً 10 مرات في الذاكرة وبالتالي قد ينتج عنه أخطاء إما في جلب البيانات ( حجم المجلد ) أو عدم دقتها ، أو سينتج الخطأ Overflow في نهاية المطاف . كما أنها لا تدعم الإيقاف أو ( ايقاف العملية ) وبالتالي قد تستمر العملية لوقت طويل دون تحكم . وهذه بالنسبة لي الطريقتين التي فهمتهما لاستدعاء الدوال في الكود الذي اقترحته .. 'مثال على مسار مجلد محدد في الكود 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 هذا من وجهة نظري ، ولا أحاول الخروج عن سياق الموضوع .

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

للأسف لم يعمل

إن شاء الله، جاري تجربة

نرجو من احد الإخوة والاساتذة الذي يمرون من هنا تجربة المرفق واخبارنا بالنتيجة .. تأجيل الاقتطاع.zip

قبل تجهيز النظام للرفع لكم لانشاء نظامكم - خفايف كود موضح في المرفق تجربة ممتعة GiveMe_File_Out_Size_File.rar

بناءً على ما فهمت من المطلوب ، هو اضافة سجلات = عدد الاشهر التي تم تأجيلها ، بشرط ان يتم تأجيل الدفعة ( القيمة ) الى الاشهر الجديدة ؛ صحيح ؟ جرب ها التعديل !!! Private Sub cmd_Do_Changes_Click() Dim rst As DAO.Recordset Dim Dat As Date Dim Remarks As String Dim i As Integer Me.Month_From = DateSerial(Year(Me.Month_From), Month(Me.Month_From), 1) If Me.Month_From < Me.DiscountStartDate Then MsgBox "آسف, شهر التأجيل الذي أدخلته أصغر من شهر بداية الإقتطاع" & vbCrLf & _ "يرجى التصحيح وحاول مرة أخرى" Exit Sub ElseIf Me.Month_From > Me.DiscountEndDate Then MsgBox "آسف, شهر التأجيل الذي أدخلته أكبر من شهر نهاية أخر إقتطاع" & vbCrLf & _ "يرجى التصحيح وحاول مرة أخرى" Exit Sub End If If Me.OpenArgs = "frmCridi" Then MySQL = "Select * From tbl_Loans Where Loan_ID = " & Me.Loan_ID & " And Loan_Type='Cridi'" Loan_Type = "Cridi" r = "" Else MySQL = "Select * From tbl_Loans Where Loan_ID = " & Me.Loan_ID & " And Loan_Type='Elec'" Loan_Type = "Elec" r = "" End If Set rst = CurrentDb.OpenRecordset(MySQL) For i = 0 To Me.Number_Of_Months - 1 Dat = Format(DateAdd("m", i, Me.Month_From), "yyyy-mm-dd") rst.FindFirst "[Payment_Month]=#" & Dat & "#" If Not rst.NoMatch Then Remarks = rst!Remarks rst.Edit rst!Loan_Made = 0 rst!Remarks = Remarks & " | " & "تأجيل الإقتطاع إلى تاريخ " & Format(DateAdd("m", i + 1, Me.DiscountEndDate), "DD-MM-YYYY") rst.Update End If rst.AddNew rst!EmployeeID = Me.EmployeeID rst!Loan_ID = Me.Loan_ID rst!Auto_Date = Me.AwardMonth rst!Payment_Month = DateAdd("m", i + 1, Me.DiscountEndDate) rst!Loan_Made = Me.DiscountPerMonth rst!Loan_Type = Loan_Type rst!Remarks = Remarks rst!annee = Year(Date) rst.Update Next i rst.Close: Set rst = Nothing Forms!frmCridi!Frm_sub!DiscountEndDate = DateAdd("m", Me.Number_Of_Months, Forms!frmCridi!Frm_sub!DiscountEndDate) Forms!frmCridi!Frm_sub!Obsérvation = Forms!frmCridi!Frm_sub!Obsérvation & " | " & _ "تأجيل الإقتطاع لمدة " & GetMoisName(i) I2 = Forms!frmCridi!Frm_sub!ID Forms!frmCridi!Frm_sub.Form.Requery Set rst = Forms!frmCridi!Frm_sub.Form.RecordsetClone rst.FindFirst "[ID]=" & I2 Forms!frmCridi!Frm_sub.Form.Bookmark = rst.Bookmark MsgBox ("تم تأجيل الإقتطاع لمدة " & GetMoisName(i)) DoCmd.Close End Sub تأجيل الاقتطاع.zip

شوف يا فؤش خطر بالى كتابة الكود بالشكل التالى فى وحده نمطية عامة ' تعداد لتحديد نوع العنصر 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

تفضل جرب هدا Dim Sh As Boolean ' إسم المصنف الجديد Private Const WBname As String = "المجمع.xlsx" Private Sub UserForm_Initialize() Dim WS As Worksheet, CrWS As Variant, i As Integer ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها CrWS = Array("Sheet1", "Sheet2", "Sheet3") For Each WS In ThisWorkbook.Worksheets For i = LBound(CrWS) To UBound(CrWS) If WS.name = CrWS(i) Then ListBox1.AddItem WS.name Exit For End If Next i Next WS End Sub Private Sub CommandButton1_Click() Dim i As Integer, ShName As String, newWb As Workbook, sPath As String Dim tmps As Integer, shArr As String, sCount As Integer tmps = 0 For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then tmps = tmps + 1 Next i If tmps = 0 And Not CheckBox1.Value Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "إنتباه" Exit Sub End If Sh = True With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With If Sh Then Set newWb = CreateWb() sPath = ThisWorkbook.path & "\" & WBname SaveNewWorkbook newWb, sPath sCount = 0 If CheckBox1.Value Then For i = 0 To Me.ListBox1.ListCount - 1 ShName = Me.ListBox1.List(i) CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb shArr = shArr & ShName & vbNewLine sCount = sCount + 1 Next i Else For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then ShName = Me.ListBox1.List(i) CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb shArr = shArr & ShName & vbNewLine sCount = sCount + 1 End If Next i End If WSDelete newWb newWb.Save newWb.Close SaveChanges:=True With Application .ScreenUpdating = True .EnableEvents = True .CopyObjectsWithCells = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With Unload Me MsgBox IIf(sCount = 1, "تم حفظ الورقة بنجاح", "تم حفظ الأوراق بنجاح") & vbNewLine & vbNewLine & shArr, vbInformation End If End Sub Private Function CreateWb() As Workbook Dim newWb As Workbook Set newWb = Workbooks.Add(xlWBATWorksheet) newWb.Sheets(1).name = "New" Set CreateWb = newWb End Function Private Sub SaveNewWorkbook(ByVal newWb As Workbook, ByVal filePath As String) On Error Resume Next newWb.SaveAs fileName:=filePath, FileFormat:=xlOpenXMLWorkbook On Error GoTo 0 End Sub Private Sub CopySheetToNewWorkbook(ByVal sourceSheet As Worksheet, ByVal targetWorkbook As Workbook) sourceSheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count) Dim WS As Worksheet Set WS = targetWorkbook.Sheets(targetWorkbook.Sheets.Count) WS.UsedRange.Value = WS.UsedRange.Value Application.CutCopyMode = False End Sub Private Sub WSDelete(ByVal newWb As Workbook) On Error Resume Next newWb.Sheets("New").Delete On Error GoTo 0 End Sub تصدير صفحات v2.xlsm

الحمد لله تعالى اشكرك جدا يا صديقى العزيز وسعيد جدا جدا بمرورك واهتمامك

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

كان لى رغبة فى معرفة بديل تنسيق yyyy/mm/dd لاستخدامها فى الحقول الـ Unbound (غير منضم ) وقد رأيتها هنا : Else birthDate = Format(CDate(birthDate), YearMonthDayFormat) ' تحويل المدخل إلى تاريخ currentDate = Format(Date, YearMonthDayFormat) ' تعيين التاريخ الحالي Format YearMonthDayFormat شكراً ابو جودي

رغم أن هدا لم يكن طلبك في أول مشاركة لاكنني أعتقد أنه الان قد تم تزويدك بجميع الحلول الممكنة للحصول على النتائج المطلوبة تم وضع الصيغ في جدول مستقل لتتمكن من مقارنة النتائج صيغ الأعمدة G + H =LET(extracted_text, IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), NUMBERVALUE(IF(ISNUMBER(FIND(" ", extracted_text)), TRIM(LEFT(extracted_text, FIND(" ", extracted_text) - 1)), extracted_text))) أو =NUMBERVALUE(IF(ISNUMBER(FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2))), TRIM(LEFT(IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)) - 1)), IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)))) صيغ الأعمدة I + J =(IFERROR(VALUE("0 "&MID(F2,FIND(" ",F2)+1,LEN(F2)-FIND(" ",F2))), 0)) + (IFERROR(VALUE("0 "& IF(ISNUMBER(FIND(" ",G2)),TRIM(RIGHT(G2,LEN(G2)-FIND(" ",G2))), 0) ), 0)) بالتوفيق......... Sum Architect Units Feet-Inches V3.xlsx

شكرا استاذ على الرد من قبل كان الكود يضيف السجلات المؤجلة ليست المشكلة هنا انظر لما نسخت الكود ونفذته "تاجيل لمدة 02 اشهر ابتداء من تاريخ : 2025/04/01 " ايش سوى حسب الصورة