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

اعتذر ارسلت الملف الخطأ ..... تفضل أخي جرب ووافني بالرد . Subform.rar

تفضل أخي برنامج اكسس عندي 64 بت حصلت المديول في المنتدى ثم قمت ببعض تعديلات لكي يعمل على نواتين 64 و 32 بت و عرض نافذة InputBox في وسط الشاشة FF.mdb

ابشر خيرا ان شاء الله

من بعد اذن اخى واستاذى @kkhalifa1960 جزاه الله كل خير @Abdelaziz Osman غير الحدث لعند الخروج Private Sub kind_Exit(Cancel As Integer) DoCmd.RunCommand acCmdSaveRecord DoCmd.SetWarnings False DoCmd.OpenQuery "Query1" DoCmd.SetWarnings True 'Me.Requery Me.AGR.Requery End Sub بالتوفيق

أنا اشتغلت على الموضوع رغم عدم الرد ولكن كي يستفيد من يهمه الأمر ..... 1- يوجد بالفولدر نموذجان وفولدران للصور . أ- النموذج (Watcher) والفولدر (ImagesWatcher) يتم فتح النموذج فيذهب لمسار فولدر صور الاشعة هذا المسار مجرب لمعمل اشعة بجواري . علشان كدة سألت عم المسار ولم يجيبني السائل ... المهم الفورم بيبحث عن أي تغييرات من زياد صور بفولدر جهاز الاشعة ويحفظها بالفولدر (ImagesWatcher) . ب- النموذج (DRTest) والفولدر (Images) يتم فتح النموذج (SwichBoard) وبه العمليات كما بالنموذج . 2- أي استفسار أنا حاضر . واليكم المرفق . Digital Radiography.rar

لايمكن لأن قبل ما تغير الكلمة بيكون حدث علشان كدة دبل كليك . تحياتي لك .

الملف يعمل بشكل جيد تفضل الشرح .

بانتظار التحديث مهندسنا المبدع

السلام عليكم يرجى تطبيق الفيديو التالي على حاسوبك علماً أن لاحقة الإكسل هي: .xlsx الرابط بالتوفيق إن شاء الله

استفسار1.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته اقتراحات من الممكن أن تستفيد منها سواءا للترتيب أو حفظ الملف Sub ExportToPDF() Dim endNum As Long, wb As Workbook, WS As Worksheet, i As Long Dim nFichier As String, chemin As String, r As String, n As Integer Set WS = Sheets("الشهادة") If IsEmpty(WS.Range("H2").Value) Then MsgBox "الرجاء تحديد إجمالي الشهادات", vbExclamation: Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False startNum = WS.[F2].Value: endNum = WS.[H2].Value Set wb = Workbooks.Add(xlWBATWorksheet) chemin = ThisWorkbook.Path & "\الشهادات\" If Len(Dir(chemin, vbDirectory)) = 0 Then MkDir chemin nFichier = WS.[B6].Value & "_" & WS.[B7].Value & ".pdf" r = chemin & nFichier If Len(Dir(r)) > 0 Then n = 1 Do r = chemin & WS.[B6].Value & "_" & WS.[B7].Value & "(" & n & ").pdf" n = n + 1 Loop Until Len(Dir(r)) = 0 End If For i = 1 To endNum WS.[F2].Value = i WS.Copy After:=wb.Worksheets(wb.Worksheets.Count) Next i WS.[F2].Value = 1 wb.Worksheets(1).Delete wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=r wb.Close False .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True End With MsgBox "تم تصدير الشهادات بنجاح في " & vbCrLf & vbCrLf & _ r, vbInformation, "تم حفظ الشهادات من " & startNum & " إلى " & endNum End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B7:S36")) Is Nothing Then Dim WS As Worksheet, i As Long, j As Long, n As Long, ky As Long, a() As Variant, tmp As Long, tbl As String Set WS = ActiveSheet Application.ScreenUpdating = False WS.Range("Y7:AA36").ClearContents For i = 7 To 36 If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _ Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then tmp = tmp + 1 Next i If tmp = 0 Then MsgBox "لا توجد بيانات", vbExclamation: Exit Sub ReDim a(1 To tmp, 1 To 3) tmp = 0 For i = 7 To 36 If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _ Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then tmp = tmp + 1 a(tmp, 1) = WS.Cells(i, "A").Value: a(tmp, 2) = WS.Cells(i, "B").Value: a(tmp, 3) = WS.Cells(i, "S").Value End If Next i For i = 1 To tmp - 1 For j = i + 1 To tmp If a(i, 3) < a(j, 3) Then r a(i, 1), a(j, 1): r a(i, 2), a(j, 2): r a(i, 3), a(j, 3) End If Next j Next i n = 1: ky = 1 WS.Cells(7, "Y").Value = 1: WS.Cells(7, "Z").Value = a(1, 2): WS.Cells(7, "AA").Value = "الأول" For i = 2 To tmp If a(i, 3) = a(i - 1, 3) Then ky = ky + 1 tbl = GetTex(n, ky) WS.Cells(i + 6, "AA").Value = tbl Else n = n + 1: ky = 1 tbl = GetTex(n, ky) WS.Cells(i + 6, "AA").Value = tbl End If WS.Cells(i + 6, "Y").Value = i: WS.Cells(i + 6, "Z").Value = a(i, 2) Next i Application.ScreenUpdating = True End If End Sub Sub r(ByRef a As Variant, ByRef b As Variant) Dim temp As Variant temp = a: a = b: b = temp End Sub Function GetTex(n As Long, ky As Long) As String GetTex = tmps(n) & IIf(ky > 1, " " & ky, "") End Function ترتيب التلاميذ تصاعديا V2.xlsm

لماذا التنسيق ؟ مادامت الكشوف شهرية .. لماذا لا تجعل التصفية برقم الشهر ورقم السنة ؟ الشيء الآخر .. خذها نصيحة .. اجتنب كتابة اسماء الكائنات والحقول بحروف عربية .. لن تتعلم ..

ابشر شغال عليه لكن ابغي منك التالي : هل جهاز الاشعة والكمبيوتر على نفس الشبكة ..... اذا نعم . ممكن تجيب مسار فولدر حفظ صور جهاز الاشعة .؟؟؟

السلام عليكم ورحمة الله تعالى وبركاته الموضوع بخصوص انشاء مجلدات الموضوع مطروح للتجربه والنقاش بفكره جديده تشمل كل الاحتمالات تقريبا التى خطرت على بالى الاكواد فى وحدة نمطيه عامة كالاتى ' استيراد كائن FileSystemObject Private fso As Object ' تهيئة كائن FileSystemObject Private Sub InitializeFSO() If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject") End If End Sub ' فحص وجود مجلد باستخدام FileSystemObject Private Function FolderExists(path As String) As Boolean InitializeFSO FolderExists = fso.FolderExists(path) End Function ' إنشاء بنية مجلدات متدرجة Private Function CreateFolderStructure(fullPath As String, ByRef errorMessage As String) As Boolean On Error GoTo ErrorHandler Dim parts() As String Dim currentPath As String Dim i As Integer ' تقطيع المسار إلى أجزاء parts = Split(fullPath, "\") currentPath = "" ' إنشاء كل جزء من المسار بشكل متدرج For i = LBound(parts) To UBound(parts) If parts(i) <> "" Then currentPath = currentPath & parts(i) & "\" If Not FolderExists(currentPath) Then fso.CreateFolder currentPath End If End If Next CreateFolderStructure = True Exit Function ErrorHandler: ' تخزين رسالة الخطأ في حال حدوث مشكلة errorMessage = "تعذر إنشاء المجلد: " & fullPath & " - الخطأ: " & Err.Description CreateFolderStructure = False End Function ' بناء مسار كامل من المسار الأساسي والمسار الفرعي Private Function BuildPath(basePath As String, subPath As String) As String ' التأكد من انتهاء المسار الأساسي بشرطة ميل (/) If Right(basePath, 1) <> "\" Then basePath = basePath & "\" ' استبدال شرط الميل ("/") بشريط الميل ("\") BuildPath = basePath & Replace(subPath, "/", "\") End Function ' تنظيف المسار وإصلاح الأخطاء الشائعة Function BuildFullPath(rawPath As String) As String Dim cleanPath As String ' إزالة الفراغات الزائدة واستبدال الرموز غير الصحيحة cleanPath = Trim(rawPath) cleanPath = Replace(cleanPath, "/", "\") ' تصحيح الأخطاء في بداية المسار (C\Test ? C:\Test) If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" And (Asc(UCase(Left(cleanPath, 1))) >= 65 And Asc(UCase(Left(cleanPath, 1))) <= 90) Then cleanPath = Left(cleanPath, 1) & ":\" & Mid(cleanPath, 3) End If ' التحقق مما إذا كان المسار يبدأ بحرف قرص (مثل C:) لكنه لا يحتوي على \ بعده، وإصلاحه If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = ":" And Mid(cleanPath, 3, 1) <> "\" Then cleanPath = Left(cleanPath, 2) & "\" & Mid(cleanPath, 3) End If If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" Then cleanPath = Left(cleanPath, 1) & ":\" & Right(cleanPath, Len(cleanPath) - 2) End If ' إذا لم يحتوي المسار على رمز قرص أو مسار شبكة، يتم ربطه بمسار المشروع الحالي If InStr(cleanPath, ":") = 0 And Left(cleanPath, 2) <> "\\" Then cleanPath = CurrentProject.path & "\" & cleanPath If Left(cleanPath, 1) = ":" Then cleanPath = CurrentProject.path & "\" & cleanPath ' تصحيح الأخطاء في كتابة المسارات cleanPath = Replace(cleanPath, "\:\", "\\") cleanPath = Replace(cleanPath, "\::\", "\") cleanPath = Replace(cleanPath, "\:", "\") ' استبدال \\ بـ \ باستثناء مسارات الشبكة \\Server\Share If Left(cleanPath, 2) <> "\\" Then cleanPath = Replace(cleanPath, "\\", "\") ' إرجاع المسار النظيف BuildFullPath = cleanPath End Function ' إنشاء مجلدات بناءً على قائمة مسارات فرعية Public Function CreateFolders(basePath As String, ParamArray folderPaths() As Variant) As String On Error GoTo ErrorHandler Dim path As Variant Dim fullPath As String Dim errorMessage As String InitializeFSO ' التحقق من وجود المسار الأساسي وإنشاؤه إذا لم يكن موجودًا If Not FolderExists(basePath) Then CreateFolderStructure basePath, errorMessage If errorMessage <> "" Then CreateFolders = errorMessage Exit Function End If End If ' إنشاء المسارات الفرعية For Each path In folderPaths fullPath = BuildPath(basePath, CStr(path)) If Not CreateFolderStructure(fullPath, errorMessage) Then CreateFolders = errorMessage Exit Function End If Next CreateFolders = "Success" Exit Function ErrorHandler: CreateFolders = "خطأ " & Err.Number & ": " & Err.Description End Function ' إنشاء مجلدات بناءً على بيانات جدول في قاعدة البيانات Public Function CreateFoldersFromTable(tableName As String, basePathField As String, Optional condition As String = "") As String On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim query As String Dim basePath As String Dim folderPath As String Dim errorMessage As String Set db = CurrentDb() ' بناء استعلام لاستخراج المسارات الفريدة query = "SELECT DISTINCT [" & basePathField & "] FROM [" & tableName & "]" If condition <> "" Then query = query & " WHERE " & condition Set rs = db.OpenRecordset(query, dbOpenSnapshot) ' التحقق من وجود سجلات If rs.BOF And rs.EOF Then CreateFoldersFromTable = "لا توجد سجلات." Exit Function End If ' إنشاء المجلدات لكل سجل Do While Not rs.EOF basePath = Nz(rs.Fields(basePathField).Value, "") folderPath = BuildFullPath(basePath) ' التحقق من صحة المسار وإنشاؤه If Not CreateFolderStructure(folderPath, errorMessage) Then CreateFoldersFromTable = errorMessage Exit Function End If rs.MoveNext Loop ' إغلاق السجلات وتنظيف الذاكرة rs.Close Set rs = Nothing Set db = Nothing CreateFoldersFromTable = "Success" Exit Function ErrorHandler: CreateFoldersFromTable = "خطأ " & Err.Number & ": " & Err.Description End Function ويتم الاستدعاء حسب خيال المبرمج وهذه امثله لصور الاستدعاء ' إنشاء مجلدات يدويا ً من خلال تمرير المسار Sub Example1() Dim result As String result = CreateFolders("C:\Project Resources", _ "Backup", _ "Fonts\Arabic", _ "Fonts\English", _ "Images\Ico", _ "Images\Logo", _ "Images\QR Code", _ "PDF", _ "Utility\Reference\MsAccess", _ "Utility\Reference\TBL") If result = "Success" Then MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات داخل مشروع Access الحالي Sub Example2() Dim result As String result = CreateFolders(CurrentProject.path & "\Project Resources", _ "Backup", _ "Fonts\Arabic", _ "Fonts\English", _ "Images\Ico", _ "Images\Logo", _ "Images\QR Code", _ "PDF", _ "Utility\Reference\MsAccess", _ "Utility\Reference\TBL") If result = "Success" Then MsgBox "تم إنشاء المجلدات داخل مشروع Access!", vbInformation Else MsgBox "حدث خطأ أثناء إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات من جدول في قاعدة البيانات Sub Example3() Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath") If result = "Success" Then MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات بناءً على فئة معينة Sub Example4() Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = 'Access'") If result = "Success" Then MsgBox "تم إنشاء المجلدات الخاصة بمكتبات Access!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات شبكة (UNC Paths) Sub Example5() Dim result As String result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath") If result = "Success" Then MsgBox "تم إنشاء المجلدات الشبكية بنجاح!", vbInformation Else MsgBox "حدث خطأ أثناء إنشاء المجلدات الشبكية: " & result, vbCritical End If End Sub ' إنشاء مجلدات شبكة بناءً على خادم معين Sub Example6() Dim result As String result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath", "Server = 'FileServer01'") If result = "Success" Then MsgBox "تم إنشاء المجلدات على FileServer01!", vbInformation Else MsgBox "فشل في العثور على مجلدات لهذا الخادم: " & result, vbCritical End If End Sub ' إنشاء مجلدات بناءً على مدخلات المستخدم Sub Example7() Dim userCategory As String userCategory = InputBox("أدخل اسم الفئة لإنشاء المجلدات:", "تحديد الفئة") If userCategory <> "" Then Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = '" & userCategory & "'") If result = "Success" Then MsgBox "تم إنشاء المجلدات للفئة: " & userCategory, vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If Else MsgBox "لم يتم إدخال فئة صحيحة!", vbExclamation End If End Sub الهدف: إنشاء مجلدات ديناميكيًا في مسار أساسي باستخدام معلومات مدخلة يدوية أو مستخلصة من قاعدة بيانات الحالات المختلفة للاستدعاء: الحالة 1: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار الحالة 2: استدعاء دالة لإنشاء مجلد /هيكل المجلدات في مجلد مشروع Access الحالي الحالة 3: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول قاعدة بيانات الحالة 4: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول مع تصفية حسب فئة معينة الحالة 5: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار الشبكي(UNC) الحالة 6: استدعاء دالة لإنشاء المجلدات من خلال مسارات من جدول مع تصفية حسب اسم الخادم المستخدم للمسار الشبكي (UNC) انشاء مجلد او هيكل مجلدات.zip

المشكلة اللي بتحصل عندك سببها أن التاريخ الذي يتم إدخاله في قاعدة البيانات يتم تفسيره بشكل خاطئ بسبب اختلاف تنسيق التاريخ بين التنسيق (الشهر/اليوم/السنة) والتنسيق الذي تستخدمه (اليوم/الشهر/السنة) . ولحل هذه المشكلة تقدر تستخدم الدالة Format لتنسيق التاريخ بالطريقة الصحيحة التي تفهمها قاعدة البيانات عندك . فاقترح تعديل الكود لاستخدام Format لضمان أن التاريخ يتم إدخاله بالشكل الصحيح . جرب التعديل التالي .. Sub DuplicateRecords() Dim db As DAO.Database Dim rs As DAO.Recordset Dim newPCode As Long Dim todayDate As String Dim sqlInsertLab As String Dim sqlInsertRequest As String Dim sqlInsertTests As String ' فتح قاعدة البيانات الحالية Set db = CurrentDb() todayDate = Format(Date, "mm/dd/yyyy") ' تنسيق التاريخ بالشكل الصحيح ' جلب آخر PCode من جدول tbl_NewLab لتجنب التكرار Set rs = db.OpenRecordset("SELECT MAX(PCode) AS MaxPCode FROM tbl_NewLab") If Not rs.EOF Then newPCode = rs!MaxPCode + 1 Else newPCode = 1 ' في حالة عدم وجود سجلات End If rs.Close ' استبدال المرجع بالصيغة الصحيحة Dim currentPCode As Long currentPCode = Forms!New_Project!newRequest.Form!PCode ' إدراج السجل الجديد في tbl_NewLab sqlInsertLab = "INSERT INTO tbl_NewLab (DDate, PCode, Pname, Name_Month, C_Year, Area, Code_Month, Mon_Year) " & _ "SELECT #" & todayDate & "#, " & newPCode & ", Pname, Name_Month, C_Year, Area, Code_Month, Mon_Year " & _ "FROM tbl_NewLab WHERE PCode = " & currentPCode db.Execute sqlInsertLab ' إدراج السجل الجديد في tbl_NewRequest sqlInsertRequest = "INSERT INTO tbl_NewRequest (PCode, TCode, Date_R, Price_R, Tname_R) " & _ "SELECT " & newPCode & ", TCode, #" & todayDate & "#, Price_R, Tname_R " & _ "FROM tbl_NewRequest WHERE PCode = " & currentPCode db.Execute sqlInsertRequest ' إدراج السجل الجديد في tbl_NewTests (إذا لزم الأمر) sqlInsertTests = "INSERT INTO tbl_NewTests (TCode, TName, Price) " & _ "SELECT TCode, TName, Price " & _ "FROM tbl_NewTests WHERE TCode IN (SELECT TCode FROM tbl_NewRequest WHERE PCode = " & currentPCode & ")" db.Execute sqlInsertTests MsgBox "تم تكرار السجل بنجاح مع تحديث PCode والتاريخ.", vbInformation End Sub Private Sub أمر4030_Click() DuplicateRecords End Sub او انك تعيد تنسيق التاريخ في كمبيوترك لما يتناسب مع المطلوب تحقيقه ..

المعذرة توي اشوف المرفق هههه يعطيك العافية

يعطيك العافي استاذة @hanan_ms شغل متعوب عليه لكن هل بالامكان اضافة المرفق لتكتمل الفائدة ؟

وعليكم السلام ورحمة الله نعالى وبركاته دالة IFS هي دالة موجودة في إصدارات Excel الحديثة ولكنها غير مدعومة في Excel 2019 يمكنك استخدام دوال أخرى مثل IF المتداخلة لتحقيق نفس الوظيفة على سبيل المثال =IF(A2="","",IF(A2<5,"ضعيف",IF(A2<10,"متوسط",IF(A2<15,"حسن","ممتاز")))) أو =IF(A2="","",CHOOSE(MATCH(A2,{0,5,10,15},1),"ضعيف","متوسط","حسن","ممتاز")) يمكنك تعديل هذه الصيغ لتشمل العديد من الشروط المتداخلة حسب حاجتك إذا كنت ترغب في محاكاة دالة IFS باستخدام VBA يمكننا كتابة دالة مخصصة تقوم بالتحقق من عدة شروط في تسلسل مشابه لدالة IFS في Module قم بلصق الكود التالي Function IFS_Formula(ParamArray tmp() As Variant) As Variant Dim i As Integer For i = LBound(tmp) To UBound(tmp) Step 2 If tmp(i) Then IFS_Formula = tmp(i + 1) Exit Function End If Next i IFS_Formula = CVErr(xlErrValue) End Function واستخدام الدالة التالية =IFS_Formula(A2="","",A2<5,"ضعيف",A2<10,"متوسط",A2<15,"حسن",A2>=15,"ممتاز") في حالة لديك حاجة مستمرة لاستخدام دالة IFS فإن الحل الأكثر فعالية سيكون الترقية إلى Excel 2021 رابط التحميل https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file حيث تكون هذه الدالة مدعومة بشكل كامل بالتوفيق............. TEST-IFS.xlsb