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

متأسف جدا بشمهندس خليفة - الخطاء مني انا في المشاركة كتب العطلة الاسبوعية الخميس والجمعة والصحيح هي الجمعة والسبت ارجوك تقبل اعتذاري

مشاركة مع الاخ @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

استاذ @gavan من وجهة نظري كل البرامج تعتمد على تقسيم القاعدة . فأنت هنا بالاكسس يمكنك تقسيم القاعدة أماميه وبها (الاستعلامات والنماذج و التقارير و الموديلات و الوحدات النمطية)، والقاعدة الخلفية وبها الجداول وممكن تقسم القاعدة الخلفية كمان مجموعة جداول بقاعدة والمجموعة الباقية بقاعدة أخرى والربط بين القاعدة الأمامية والقواعد الخلفية بالطريقة السليمة . تحياتي .

وعليكم السلام ورحمة الله تعالى وبركاته Sub transfert() Dim desWS As Worksheet: Set desWS = Sheets("تجميع") Dim i As Byte, F As Variant Application.ScreenUpdating = False desWS.Range("a2:j" & Rows.Count).ClearContents For i = 1 To Worksheets.Count If UCase(Sheets(i).Name) <> desWS.Name Then With Sheets(i) F = .Range("A10:G10", .Range("a" & Rows.Count).End(xlUp)) desWS.[A65000].End(xlUp).Offset(2).Resize(UBound(F), 7) = F End With End If Next Application.ScreenUpdating = True End Sub في حالة الرغبة بتنسيق الجداول يمكنك اظافة الاسطر التالية اسفل الكود 'تنسيق الجداول '''*****تسطير***** With desWS lastrow = .Range("A:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = .Range("A2 :G" & lastrow) For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next '''****تمييز رؤوس الاعمدة*** Set j = .Range("a2:a" & lastrow) For Each r In j If r.Value = "ر.ت" Then _ If rng Is Nothing Then Set rng = r.Resize(1, 7) Else Set rng = Union(rng, r.Resize(1, 7)) Next If Not rng Is Nothing Then rng.Interior.Color = RGB(204, 204, 255): rng.Font.Bold = True End With ListEleve_20240320 V2.xlsm

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم بكل خير وسرور .. وتقبل الله منا ومنكم صالحات الأعمال .. 😊🤲🏻 يطيب لي أن أقدم لكم هذا الهدية المتواضعة بمناسبة هذا الشهر الفضيل 🙂🌼🎁 استبدل الرسائل العادية في أكسس برسائل ذات تصاميم قمة في الإبداع وبمميزات إضافية . من مميزات هذه الرسائل: - تصميم جميل وألوان جذابة. - خاصية ذاتية الاختفاء. - عنوان رئيسي + عنوان فرعي - تحكم بالنص ( عربي - إنجليزي ) ( توسيط - محاذاة على اليمين أو اليسار) - سهلة الاستخدام . الشرح على اليوتيوب : التحميل 🙂 Moosak MsgBox.accdb ولا تنسوني من صالح دعواتكم 😊🌷🌼🌹

السلام عليكم ورحمة الله وبركاته اهلا بك بشمهندش foksh رمضان كريم حسب قانون العمل لايتم احتساب يومي الجمعة والسبت من ضمن اجازة الموظف لانه طبيعي انهم عطله ممنوحة من الدولة له لهذا السبب يتم خصمها وهذا فقط يحدث في حال نوع الاجازة هو الاجازة السنوية والتي له رصيد منها اما اذا كان نوع الاجازة غير ذلك طارئة او حج او عمره او غيره فكما ذكرت بشمهنس لايتم احتساب الجمعة والسبت كيومي عطلة

الله يبيض وجهك أخوي سامي الحداد ... ورحمك الله ووالديك ألف شكر لك يا عزيزي والشكر موصول للعزيز الغالي Foksh ايعمل بامتياز👍

لي تعليق على نظام الاجازات في قانون العمل والعمال .. اذا الموظف أخذ اجازة 3 ايام لنفرض انها بدأت من الخميس 21/03/2024 ،فهذا يعني ان أيام الجمعة والسبت كأيام عطلة رسمية يتم احتسابهم من أيام الإجازة وإلا فإن الموظف سيباشر عمله صباح الثلاثاء ( خميس وأحد وإثنين ) ، وهذا ليس منطقي أما إذا انتهت الإجازة مساء الخميس ولحقها يومي عطلة رسمية (جمعة وسبت) وباشر الموظف عمله يوم الأحد فإن الجمعة والسبت لا يتم احتسابها كأيام غياب في نظام شؤون الموظفين.

ايشر غداً انشاء الله ورمضان كريم .

تفضل استاذ @SAROOK المرفق حسب مافهمت . ووافني بالرد . الاجازات (4).rar

استاذ @2saad أولاً........... لماذا لم ترد على المشاركة السابقة لطلبك استخراج المحافظة من الرقم القومي والسن في أول اكتوبر ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟ ثانياً ........... بالنسبة لطلبك تطبيق الكود على الجدول (Data) ... الجدول به حقل الصورة (Attachment) فلايمكن عمل لها (Update) وسيخرج لك (Error) لذا استخدم الكود التالي .بالمرفق . قاعدة بيانات مدرسية (22).rar

انظر هنا قد يفيدك

بسم الله الرحمن الرحيم.. السلام عليكم ورحمة الله وبركاته.. بعد طول غياب عن الساحة بسبب ضروف الحياة والعمل.. اقدم لكم اداة صغيرة من برمجتي بلغة Visual Studio .NET تقوم بالتقاط الصور كاميرا الويب او اي كاميرا متصلة بالكومبيوتر ومن ثم خزنها في الجهاز الاداة قمت بربطها مع الاكسس، بحيث تقوم بتمرير براميتر من الاكسس الى الاداة وهذا البراميتر متمثل بـ مسار حفظ الصورة + واسم الصورة + صيغتها مثال: Dim SavedPath As String SavedPath = """" & CurrentProject.Path & "\Capture.png" & """" الاداة تستخدم مكتبات AForge للتحكم بالكاميرات. صورة الاداة: بمجرد ان تضغط زر Open Camera من الاكسس ستعمل الاداة مباشرة قم بترتيب الكاميرا الخاصة بك لاخذ لقطة مناسبة واضغط على الزر Snapshot ثم اضغط على الز save لحفظ الصورة. الاداة اخذت مني وقت 8 ساعات في البرمجة لذلك لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. SEMO_webCam.rar كلمات مفتاحية: التقاط صورة من الكاميرا، حفظ الصورة من الكاميرا، جلب الصورة من كاميرا الويب، جلب الصورة من الكاميرا وحفظها في قاعدة البيانات، حفظ الصور بقاعدة البيانات، خزن الصورة من الكاميرا كاميرا ويب قاعدة بيانات اكسس، اكسس كاميرا الويب، اكسس كاميرا، جلب الصورة من الكاميرا

السلام عليكم ...تقبل الله اعمال جميع الزملاء والاساتذة الكرم افتح النموذج وقم بلصق بعض الارقام (اجعل بينها فواصل)..اضغط على زر استيراد الارقام..عملت لك بعض الارقام في NotePad قم بنسخها ولصقها في مربع النص ثم افتح الاستعلام codeM.rar

مبدع يالغالي تحياتي 🌹🌹🌹

إطلالتك هي الأروع أخي @SAROOK 🙂

التغيير اخي سوف يكون هنا لكن يجب اولا اظافة الشرط الثاني ودالك باظافة كومبوبوكس جديدة وليكن اسمه T2 مثلا من If Rng(i, 4) >= Clé Then الى If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then وافراغ جميع الاكواد السابقة من على اليوزرفورم ونسخ الكود التالي Dim F, rng, Col, width, j, Total() Private Sub UserForm_Initialize() Dim WS As Worksheet: Set WS = Sheets("data") Set d = CreateObject("scripting.dictionary") Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row) rng = F.Value ' الاعمدة الظاهرة على الليست بوكس Col = Array(5, 4, 3, 2, 1) width = Array(100, 100, 100, 100, 100) ' تنسيق عمود المبلغ For i = LBound(rng) To UBound(rng): rng(i, 5) = Format(rng(i, 5), "#,##00.00"): Next i Me.Ls_ATA.ColumnCount = UBound(Col) + 1 Me.Ls_ATA.ColumnWidths = Join(width, ";") Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col) Total = Col: j = UBound(Total) + 1 ' عمود الفلترة ColTri = 4 For i = LBound(rng) To UBound(rng) d(rng(i, ColTri)) = "" Next i ValTri = d.keys ' ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر P rng, 4, LBound(rng), UBound(rng) ' ترتيب تصاعدي لارقام الفواتير tri ValTri, LBound(ValTri), UBound(ValTri) ' جلب اصغر عدد Me.T1.List = ValTri: Me.T1 = ValTri(0) ' جلب اكبر عدد Me.T2.List = ValTri: Me.T2 = ValTri(UBound(ValTri)) MySum End Sub '***************** Sub Filtre() 'فلترة البيانات Dim Tbl(): n = 0: Clé = Val(Me.T1): Clé2 = Val(Me.T2) For i = 1 To UBound(rng) If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n) C = 0 For Each k In Total C = C + 1: Tbl(C, n) = rng(i, k) Next k End If Next i If n > 0 Then Me.Ls_ATA.Column = Tbl MySum Else Me.Ls_ATA.Clear End If End Sub '******combobox (T1 AND T2) 'ترتيب تصاعدي************* Sub tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub '***ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر****** Sub P(a, V, gauc, droi) ref = a((gauc + droi) \ 2, V) g = gauc: d = droi Do Do While a(g, V) < ref: g = g + 1: Loop Do While ref < a(d, V): d = d - 1: Loop If g <= d Then For k = LBound(a, 2) To UBound(a, 2) temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp Next k g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call P(a, V, g, droi) If gauc < d Then Call P(a, V, gauc, d) End Sub '******************************* Sub MySum() Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0 With Ls_ATA For r = 0 To .ListCount - 1 Cnt = Cnt + 1 'عدد النتائج Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ Next r End With LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2 End Sub '******************************* Private Sub T2_click() If Val(Me.T2) < Val(Me.T1) Then MsgBox "يجب أن يكون الحد الادنى لعدد الفواتير اكبر اويساوي " & Me.T1.Text, vbExclamation, "انتباه" Else Filtre End Sub Private Sub T1_click() If Val(Me.T1) > Val(Me.T2) Then MsgBox "يجب أن يكون الحد الاقصى لعدد الفواتير اصغر او يساوي " & Me.T2.Text, vbExclamation, "انتباه" Else Filtre End Sub اليك الملف للتجربة V3 تجربة (1).xlsm

جمال وابداع روعة الصراحة سلمت يداك

فكرة !! في مديول ( وحدة نمطية ) ضع الكود التالي:- Function IsChromeOpen() As Boolean Dim objShell As Object Dim objChrome As Object On Error Resume Next Set objShell = CreateObject("Shell.Application") Set objChrome = objShell.Windows("chrome.exe") If Not objChrome Is Nothing Then IsChromeOpen = True Else IsChromeOpen = False End If Set objChrome = Nothing Set objShell = Nothing End Function ثم في النموذج يمكنك وضع هذه الوظيفة للتأكد من حالة المتصفح :- Private Sub CheckChromeStatusBtn_Click() If IsChromeOpen() Then MsgBox "المتصفح Chrome مفتوح." Else MsgBox "يجب فتح المتصفح Chrome." End If End Sub وتستطيع توليفه كما تشاء حسب حاجتك 😊 جربه واخبرني بالنتيجة 🤗

كفكرة جانبية.. لم لا تقوم بإضافة البيانات التي في النموذج الى جدول مؤقت عن طريق استعلام إضافة ، ثم تصدير هذه البيانات الى آكسيل باستعمال إحدى الطرق التي تم ذكرها ، ثم تفريغ الجدول بعد ذلك حتى لا تختلط البيانات ، كونك ترغب بترحيل بيانات محددة معروضة في النموذج الحالي !!!

حياك الله أخي سليمان .. - نموذج الصفحة الرئيسية هو منطلقك للدخول إلى باقي أجزاء البرنامج المختلفة .. 🙂 - نعم يمكنك تطويره كما تشاء 🙂✌️

السلام عليكم ورحمة الله وبركاته، كيف حالكم اخواني الأفاضل. مبارك عليكم حلول شهر رمضان المبارك أعاده الله علينا وعليكم باليمن والخير والبركات. اقدم لكم فنكشن لإحتساب المدة بين تاريخين سنة - شهر - اسبوع - ساعة - دقيقة - ثانية سؤال: ما الفائدة من هذا الفنكشن؟ بالدرجة الأولى سيُفيد أصحاب برامج الأقساط والتقسيط لإحتساب فترات التأخير والإستحقاق وغيرها. وربما هنالك استخدامات أخرى له، حسب احتياج كل شخص الفنكشن: Public Function MainElapsedTime(d1, d2) As String d1 = CDate(d1) d2 = CDate(d2) vSecs = DateDiff("s", [d1], [d2]) MainElapsedTime = ElapsedTimeAsTextRecur(vSecs) End Function Public Function ElapsedTimeAsTextRecur(ByVal pvSecs, Optional ByVal pvSecBlock) 'recursive time lapse given seconds Dim vTxt Dim iNum As Long Const kDAY = 86400 Const kSECpYR = 31536000 '60 sec = 1 min = 60 sec '60 min = 1 hour = 3,600 sec '24 hour = 1 day = 86,400 sec '07 days = 1 week = 604,800 sec '30 days = 1 month = 25,92,000 sec '12 months = 1 year = 31,536,000 sec 'YEARS If IsMissing(pvSecBlock) Then pvSecBlock = kSECpYR iNum = pvSecs \ pvSecBlock Select Case pvSecBlock Case kSECpYR 'yr sUnit = "years" If iNum > 0 Then vTxt = iNum & " Years " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 2592000) Case 2592000 'MO sUnit = "months" If iNum > 0 Then If iNum > 11 Then iNum = 11 vTxt = vTxt & iNum & " Months " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 604800) Case 604800 'WEEK sUnit = "weeks" If iNum > 0 Then If iNum > 3 Then iNum = 3 vTxt = vTxt & iNum & " Weeks " pvSecs = pvSecs - (iNum * kDAY * 7) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 86400) Case kDAY 'day sUnit = "days" If iNum > 0 Then vTxt = vTxt & iNum & " Days " pvSecs = pvSecs - (iNum * kDAY) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 3600) Case 3600 'hrs sUnit = "hrs" If iNum > 23 Then iNum = 23 If iNum > 0 Then vTxt = vTxt & iNum & " Hours " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 60) Case 60 'min sUnit = "mins" If iNum > 0 Then vTxt = vTxt & iNum & " Minutes " pvSecs = pvSecs - (iNum * pvSecBlock) End If vTxt = vTxt & ElapsedTimeAsTextRecur(pvSecs, 1) Case Else sUnit = "secs" If pvSecs > 0 Then vTxt = vTxt & pvSecs & " Seconds" End Select ElapsedTimeAsTextRecur = vTxt End Function الإستخدام بسيط جدا في الإستعلامات او في النماذج او التقارير كالآتي: MainElapsedTime("Here your date", Date()) --------------------------------------------------- Example: MsgBox MainElapsedTime("6/3/2020", "14/4/2021") النتيجة: هنا انا قمت بمقارنة تاريخين فقط بدون أوقات، سأقوم الآن بمقارنة تاريخ مع وقت MsgBox MainElapsedTime("2/02/2019 12:07:16 pm", "13/04/2021 1:08:6 am") النتيجة: للأمانة الكود ليس من كتابتي 100%، فقط انا قمت بالتعديل عليه ليصبح بشكل افضل.. تحياتي وانتضرو مفاجئتي في الموضوع القادم