سامي الحداد

مشاركة مع الاخ @Foksh Option Compare Database Option Explicit Private Sub Command0_Click() ExecuteIfChromeOpen End Sub Function IsChromeRunning() As Boolean Dim strCommand As String Dim strOutput As String Dim objWShell As Object Set objWShell = CreateObject("WScript.Shell") strCommand = "tasklist /FI ""IMAGENAME eq chrome.exe""" strOutput = objWShell.Exec(strCommand).StdOut.ReadAll If InStr(strOutput, "chrome.exe") > 0 Then IsChromeRunning = True Else IsChromeRunning = False End If Set objWShell = Nothing End Function Sub ExecuteIfChromeOpen() If IsChromeRunning() Then MsgBox " المتصفح كروم قيد التشغيل. سيتم تنفيذ الأمر", vbInformation, "تأكيد" DoCmd.OpenForm "البيانات" Else MsgBox "يجب فتح المتصفح .", vbExclamation, "المتصفح مغلق" End If End Sub واليك المرفق بالتوفيق Database313.accdb

هل هذا هو المطلوب ؟ حسب ما فهمت هل هذا هو المطلوب؟ Private Sub Form_Load() Dim pdfPath As String pdfPath = "C:\Users\LENOVO\Documents\1222.pdf" ' استبدل المسار Me.WebBrowser0.Object.Navigate pdfPath End Sub

نعم ممكن عملها كما عملت وهذه طريقتي اليك التعديل Public Sub ExtractImage() Dim Db As DAO.Database Dim Rs_p As DAO.Recordset2 Dim Rs_c As DAO.Recordset2 Dim sPath As String Dim sFile As String Dim SpecificFileName As String SpecificFileName = "Image1" sPath = CurrentProject.Path & "\Images\" Set Db = CurrentDb Set Rs_p = Db.OpenRecordset("SELECT * FROM MsysResources WHERE [type]='img' AND [Name]='" & SpecificFileName & "';", dbOpenDynaset) With Rs_p If Not (.BOF And .EOF) Then .MoveFirst MKDir sPath Do Until .EOF Set Rs_c = .Fields("Data").Value sFile = sPath & .Fields("Name") & "." & .Fields("Extension") If Len(Dir$(sFile)) <> 0 Then Kill sFile End If Rs_c.Fields("FileData").SaveToFile sFile Set Rs_c = Nothing .MoveNext Loop MsgBox " : تمت عملية إستخراج الصور الى " & sPath, vbInformation + vbMsgBoxRight, "تأكيد" End If .Close End With Set Rs_p = Nothing Set Db = Nothing End Sub Public Sub MKDir(ByVal sPath As String) Dim var As Variant, v As Variant Dim sPth As String var = Split(sPath, "\") On Error Resume Next For Each v In var sPth = sPth & v VBA.MKDir sPth sPth = sPth & "\" Next v End Sub بالتوفيق

نعم ممكن اليك الكود Option Compare Database Option Explicit Private Sub Command2_Click() ExtractImage End Sub Public Sub ExtractImage() Dim Db As DAO.Database Dim Rs_p As DAO.Recordset2 Dim Rs_c As DAO.Recordset2 Dim sPath As String Dim sFile As String sPath = CurrentProject.Path & "\Images\" Set Db = CurrentDb Set Rs_p = Db.OpenRecordset("select * from MsysResources where [type]='img';", dbOpenDynaset) With Rs_p If Not (.BOF And .EOF) Then .MoveFirst MKDir sPath Do Until .EOF Set Rs_c = .Fields("Data").Value sFile = sPath & .Fields("Name") & "." & .Fields("Extension") If Len(Dir$(sFile)) <> 0 Then Kill sFile End If Rs_c.Fields("FileData").SaveToFile sFile Set Rs_c = Nothing .MoveNext Loop MsgBox " : تمت عملية إستخراج الصور الى " & sPath, vbInformation, "تأكيد" End If .Close End With Set Rs_p = Nothing Set Db = Nothing End Sub Public Sub MKDir(ByVal sPath As String) Dim var As Variant, v As Variant Dim sPth As String var = Split(sPath, "\") On Error Resume Next For Each v In var sPth = sPth & v VBA.MKDir sPth sPth = sPth & "\" Next v End Sub سيتم إنشاء مجلد بجانب قاعدة البيانات باسم Images يمكنك تغير اسم المجلد كما تريد وسيتم استخراج كافة الصور و الايقونات من قاعدة البيانات وحفظها في المجلد. وهذا ملفك مع الكود وتم إضافة ايقونات 2 للتجربة بالتوفيق saveimage2.accdb

أخي انت لم تستخدم الكود الذي ذكرته لك وحتى لم تكلف نفسك بتجربته على العموم نفس الكود اعلاه يعمل. فقط كلف نفسك وانقله الى ملفك يعني نسخ ولصق . وهذا ملفك مع نفس الكود اعلاه error (1).accdb

وعليكم السلام تفضل اخي التعديل على الكود حسب ما فهمت Private Sub Command0_Click() Dim Result As Variant Result = DLookup("feq", "test_tbl") If Len(Result & "") = 0 Then MsgBox "Equation not found or is empty.", vbExclamation Else If IsNumeric(Result) Then Me.E = Result Else Me.E = DLookup("result", "test_order_tbl", "[tcode] = 17") / DLookup("result", "test_order_tbl", "[tcode] = 16") End If End If End Sub بالتوفيق

مشاركة مع الاساتذة جرب هذا التعديل Private Sub Command84_Click() Dim cityCode As String Dim strSQL As String ' استخراج كود المدينة من المربع النصي cityCode = Me.Text82.Value ' التحقق من أن تم إدخال كود المدينة If Len(cityCode) > 0 Then ' نقل السجلات المستهدفة إلى جدول مؤقت "Test" strSQL = "SELECT * INTO Test FROM [BASIC_DATE] WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Delete4 strSQL = "UPDATE Test SET crn = Right(crn, Len(crn)-4) WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Delete3 right strSQL = "UPDATE Test SET crn = Left(crn,Len(crn)-3) & Right(crn,2) WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Repete strSQL = "UPDATE Test SET crn = Left([crn],2)+[crn] WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Addo strSQL = "UPDATE Test SET crn = crn & '00' WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' حذف السجلات من الجدول الأصلي "BASIC_DATE" DoCmd.RunSQL "DELETE FROM [BASIC_DATE] WHERE Left(crn, 4) = '" & cityCode & "';" ' إدراج السجلات المحدثة من "Test" إلى الجدول الأصلي "BASIC_DATE" DoCmd.RunSQL "INSERT INTO [BASIC_DATE] SELECT * FROM Test;" ' حذف الجدول المؤقت "Test" DoCmd.DeleteObject acTable, "Test" ' رسالة تأكيد MsgBox "تم تحديث السجلات بنجاح!", vbInformation DoCmd.Requery Else ' رسالة في حالة عدم إدخال كود المدينة MsgBox "الرجاء إدخال كود المدينة أولاً!", vbExclamation End If End Sub

مشاركة مع الاستاذ @SAROOK جزاه الله خيرا Private Sub document_name_AfterUpdate() Dim Msg, Style, Title, Response Dim XX As Variant XX = [document name] If (Eval("dlookup(""[document name]"",""[input]"",""[nomber] =form![document name]"") Is Not Null")) Then Msg = "الكتاب رقم" & " " & XX & " " & vbCrLf & _ "قد تم ادخاله سابقا " & vbCrLf & vbCrLf & _ "Yes : نعم اذهب الى ذلك السجل" & vbCrLf & _ "No : فقط الغي هذا السجل" Style = vbYesNo + vbCritical + vbDefaultButton2 + vbMsgBoxRight Title = "تحذير الرقم مكرر !! " Response = MsgBox(Msg, Style, Title) If Response = vbYes Then ' DoCmd.GoToControl "document name" DoCmd.FindRecord XX, , , , , acAll, True End If Me.Undo End If End Sub وهذا الملف بعد التعديل بالتوقيق abcd.rar

الشكر لله عز وجل حياك الله وجزاك الله خيرا تحياتي

وعليكم السلام تفضل اخي الكريم Private Sub Cmdshow_Click() Me.txt = "" Me.Form.RecordSource = "" Me.Form.RecordSource = "SELECT * FROM Qtb " Me.Form.RecordSource = "Qtb" End Sub واليك الملف بعد التعديل test (2).accdb

السلام عليكم مشاركة مع معلمنا القدير ابو خليل تفضل اخي البحث عن طريق الكود وليس الاستعلام Private Sub Text1_J_Change() Dim strFilter As String, strSearch As String If Nz(Me.Text1_J.Text) = "" Then Me.DataSearch_J.Form.Filter = "" Me.DataSearch_J.Form.FilterOn = False Else strSearch = Replace(Me.Text1_J.Text, "'", "''") strFilter = strFilter & "Branch LIKE '*" & strSearch & "*' OR " strFilter = strFilter & "SubStatement LIKE '*" & strSearch & "*' OR " strFilter = strFilter & "BondNo LIKE '*" & strSearch & "*' OR " strFilter = strFilter & "BondSerial LIKE '*" & strSearch & "*'" End If If strFilter <> "" Then Me.DataSearch_J.Form.Filter = strFilter Me.DataSearch_J.Form.FilterOn = True Else Me.DataSearch_J.Form.Filter = "" Me.DataSearch_J.Form.FilterOn = False End If Me.Text1_J.SetFocus Me.Text1_J.SelStart = Len(Me.Text1_J.Text) End Sub عملت لك البحث في اربعة حقول Branch و SubStatement و BondNo و BondSerial بالامكان إضافة حقول اخرى للتصفية عسى ان يكون هو المطلوب بالتوفيق البحث في النموذج.rar

اخوي العزيز اسف على التاخير اليك التعديل كما طلبت. اليك الملف بالتوفيق للمسح من سكانر نوع اوتوماتيك فيدر وبدن تحديد عدد الصور.rar

وعليكم السلام جرب هذا التعديل اخي الكريم Private Sub نص15_AfterUpdate() If Me.NewRecord = False Then If Not IsNull(DLookup("end_date", "HOL", "end_date = #" & Me.end_date & "# AND ID <> " & Me.id)) Then MsgBox "هذا التاريخ متكرر..يرجى اعادة الادخال " Me.Undo End If End If If [نص15] < [نص21] Then MsgBox "تاريخ نهاية الاجازة أصغر من تاريخ البداية ", , "مع تحياتي" Me.Undo End If End Sub Private Sub نص21_AfterUpdate() If Me.NewRecord = False Then If Not IsNull(DLookup("start_date", "HOL", "start_date = #" & Me.start_date & "# AND ID <> " & Me.id)) Then MsgBox "هذا التاريخ متكرر..يرجى اعادة الادخال " Me.Undo End If End If End Sub واليك الملف بالتوفيق الاجازات.accdb

فعلا غريب سابحث في هذا الموضوع و اوافيك ان شاءالله

السلام عليكم تفضل اخي الكريم حسب ما فهمت من طلبك. Private Sub cmd_add_pic_Click() On Error GoTo ErrHandler If IsNull(Emp_Code) Or Emp_Code = "" Then DoCmd.OpenForm "frmMassage" Forms!frmMassage!lblMassage.Caption = "فضلاً يجب أن تقوم بإدخال كود الموظف حتى تتمكن من إضافة صورة الموظف" Me.Emp_Code.SetFocus Else Dim employees_Photo_Path As String employees_Photo_Path = GetOpenFile_CLT("c:\windows\desktop\", ".حدد مكان الصورة") If employees_Photo_Path <> "" Then Me![Import_pictures_path] = employees_Photo_Path Me![Import_pictures_path] = LCase(Me![Import_pictures_path]) Me![Image].Picture = Me![Import_pictures_path] Dim Project_path As String Project_path = Application.CodeProject.Path Dim EmployeeFolder As String EmployeeFolder = Project_path & "\Images_Company\Employees_Photo\" & Me.Emp_Name If Dir(EmployeeFolder, vbDirectory) = "" Then MkDir EmployeeFolder End If Dim Dir_employees_Photo As String Dir_employees_Photo = EmployeeFolder & "\" & Me.Emp_Code & ".jpg" FileCopy employees_Photo_Path, Dir_employees_Photo Me.TxtImagePath = Dir_employees_Photo Me.Image_d.Visible = False End If End If ErrHandler: If Err.Number = 94 Then Resume Next End If End Sub واليك الملف بالتوفيق test scan4-للمسح من سكانر نوع اوتوماتيك فيدر وبدن تحديد عدد الصور.mdb

الشكر لله عز وجل. حياك الله اخي الكريم.

السلام عليكم اخي الكريم جرب اولا تشغيل الاكسس في الوضع الآمن لمعرفة ما إذا كانت المشكلة مستمرة. في الوضع الآمن يبدأ الوصول باستخدام الحد الأدنى من الميزات ويمكن أن يساعد في تحديد ما إذا كانت الوظيفة الإضافية أو مكون الجهة الخارجية هو الذي يسبب المشكلة. ثانيا من الممكن أن يكون ملف تعريف المستخدم تالفًا. حاول إنشاء ملف تعريف مستخدم جديد على جهاز الكمبيوتر ومعرفة ما إذا كانت المشكلة مستمرة عند استخدام الاكسس مع ملف التعريف الجديد. ثالثا تحقق من خيارات الوصول للتأكد من تعيين ورقة الخصائص للعرض. انقر فوق علامة التبويب "ملف"، وحدد "خيارات"، وانتقل إلى قسم "قاعدة البيانات الحالية" أو قسم "مصممي الكائنات"، تأكد من ضبط خيار "ورقة الخصائص" على "المستندات المبوبة" أو "النوافذ المتداخلة". تحقق من هذه الاشياء قبل ان تعيد تسطيب الويندوز. بالتوفيق

جرب التعديل Private Sub FindDates_Click() Dim startDateFrom As Date Dim startDateTo As Date Dim endDateFrom As Date Dim endDateTo As Date Dim filterCondition As String If Not IsNull(Me.txtStartFrom) And Not IsNull(Me.txtStartTo) Then startDateFrom = DateValue(Me.txtStartFrom.Value) startDateTo = DateValue(Me.txtStartTo.Value) filterCondition = "(Date1 >= #" & Format(startDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(startDateTo, "yyyy-mm-dd") & "#) OR " & _ "(Date2 >= #" & Format(startDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(startDateTo, "yyyy-mm-dd") & "#)" End If If Not IsNull(Me.txtEndFrom) And Not IsNull(Me.txtEndTo) Then endDateFrom = DateValue(Me.txtEndFrom.Value) endDateTo = DateValue(Me.txtEndTo.Value) If filterCondition = "" Then filterCondition = "(Date1 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#) OR " & _ "(Date2 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#)" Else filterCondition = filterCondition & " OR " & _ "(Date1 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#) OR " & _ "(Date2 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#)" End If End If If filterCondition <> "" Then Me.Filter = filterCondition Me.FilterOn = True Else Me.FilterOn = False End If End Sub بحث.accdb

السلام عليكم جرب الكود التالي Option Compare Database Option Explicit Private Sub EnablePropertySheet() Dim obj As Object For Each obj In CommandBars If obj.Index < 10 Then obj.Enabled = True End If Next obj End Sub Private Sub DisablePropertySheet() Dim obj As Object For Each obj In CommandBars If obj.Index < 10 Then obj.Enabled = False End If Next obj End Sub Private Sub BtnOn_Click() On Error GoTo ErrHandler CommandBars("Property Sheet").Enabled = True ErrHandler: If Err Then Call EnablePropertySheet End Sub Private Sub BtnOff_Click() On Error GoTo ErrHandler CommandBars("Property Sheet").Enabled = False ErrHandler: If Err Then Call DisablePropertySheet End Sub مجرد تعديل بسيط على كود الاستاذ ابو جودي. لقد جربته الان على نسخة 2021 ويعمل بكفاءه. واليك المرفق بالتوفيق property sheet visible or not _ UP V2.mdb

السلام عليكم مشاركة مع الاساتذة حسب ما فهمت . عملت كمبوبوكس عدد 2 تاريخ بداية العقد ونهاية العقد وبدون استعلام فقط الكود التالي Private Sub FindDates_Click() Dim startDate As Date Dim endDate As Date If Not IsNull(Me.CboStartDate.Value) And Not IsNull(Me.CboEndDate.Value) Then startDate = DateValue(Me.CboStartDate.Value) endDate = DateValue(Me.CboEndDate.Value) If endDate >= startDate Then Me.Filter = "(Date1 = #" & Format(startDate, "yyyy-mm-dd") & "# AND Date2 = #" & Format(endDate, "yyyy-mm-dd") & "#) OR " & _ "(Date1 = #" & Format(endDate, "yyyy-mm-dd") & "# AND Date2 = #" & Format(startDate, "yyyy-mm-dd") & "#)" Me.FilterOn = True Else MsgBox ".يجب أن يكون تاريخ الانتهاء أكبر من أو يساوي تاريخ البدء", vbExclamation, "خطاء في نطاق التاريخ" End If Else Me.FilterOn = False End If End Sub عسى ان يكون هدا طلبك بالتوفيق بحث.accdb

السلام عليكم مشاركة مع الاستاذ @kkhalifa1960 جزاه الله خيرا لما يقدمه وجعله في ميزان حسناته. تفضل اخي الكريم حسب طلبك الاختيار من الكمبو بوكس. عملت لك فورم ثاني باسم Query2 بالاصافة الى الفورم الاصلي 1 لا يوجد اختلاف ففط التصميم لسهولة الوصول للمعلومة . تستطيع ان تبحث في رقم الموديل واسم الصنف . اليك المرفق بالتوفيق Database2.accdb

حياك الله اخي الكريم الشكر لله عز وجل ولاساتذتنا الذين تعلمنا منهم وما زلنا نتعلم منهم . بالتوفيق

السلام عليكم اخي الكريم نعم معك حق .. الدالة لم تكن تعمل بشكل صحيح اليك التعديل وبالنسبة الى إرجاع الدالة شهرين و-1 يوم بدلاً من 59 يومًا هو أنها تستخدم الدالة DateDiff مع الفاصل الزمني "m"، الذي يحسب عدد أشهر التقويم بين تاريخين وهذا يعني أنه يتجاهل العدد الفعلي للأيام في كل شهر وينظر فقط إلى الفرق بين أجزاء الشهر من التواريخ. على سبيل المثال، الفرق بين 01/07/2024 و01/08/2024 هو شهر واحد، على الرغم من وجود 31 يومًا بينهما. Function CalculateRemainingPeriod(StartDate As Date, EndDate As Date) As String Dim Years As Long Dim Months As Long Dim Days As Long Dim Result As String Dim TodayDate As Date TodayDate = Date Years = DateDiff("yyyy", TodayDate, [نهاية عقد العمل]) TodayDate = DateAdd("yyyy", Years, TodayDate) Months = DateDiff("m", TodayDate, [نهاية عقد العمل]) TodayDate = DateAdd("m", Months, TodayDate) Days = DateDiff("d", TodayDate, [نهاية عقد العمل]) Result = Years & " years, " & Months & " months, " & Days & " days" CalculateRemainingPeriod = Result End Function الملف بعد التعديل التاريخ.accdb

ساتحقق من هذا فقط امهلني بعض الوقت.

أخي الكريم @imad2024 يمكنك التأكد من حساب الايام يوجد العديد من المواقع يهذا الخصوص وعلى سبيل المثال هذا الموقع Date Calculator - Calculate Duration Between Two Dates (indiatimes.com) بامكانك التأكد ضع اي تاريخ وقارن النتيجة مع البرنامج. التعديل الاخير صحيح اخي الكريم لقد اجريت الكثير من التجارب على التعديل الاخير وتاكدت من عدة مواقع بخصوص حساب التاريخ . تحياتي