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

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

أخونا الغالي @عبدالعليم اسماعيل هذه مساهمة بسيطة ، وأتمنى تلقى إعجابك PatternLock.accdb

السلام عليكم ورحمة الله جرب الملف المرفق (يجب مراجعة التنسيق الشرطي على العلامات)... برنامج شهادات.xls

السلام عليكم ورحمة الله محاولة في المرفقات بالمعادلات (مع إضافة عمود للترتيب في كل صف في جدول البيانات)... اداة ارقام جلوس.xls

السلام عليكم ورحمة الله من أي ناحية لم تعرف كيف تتعامل مع الملف... تختار أولا الصف الذي تريد طباعة أرقام الجلوس تبعه من القائمة المنسدلة في الخلية V6 ثم تملأ (يدويا) الخليتين من ... إلى ... (في الخلايا V9 وW9) إذا تريد الطباعة باستعمال خاصية "من... إلى..." ثم تضغط على الزر الموافق لهذا الاختيار PRINT From_To وإذا كنت تريد الطباعة كل أرقام الجلوس في هذا الفصل تضغط مباشرة على الزر PRINT_ALL... وليس لي شرح آخر... في المرفقات قمت بالتعديل على ماكرو الطباعة (الجزئية والكلية) لكي يعمل الملف على نسختي 2003 و 2007... والله أعلم. اداة ارقام جلوس.xls

هذه فقط تظهر معك لعدم ضبط اللغة العربية لديك , فعليك بضبطها وأوضحنا هذا من قبل كثير جداً

Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim MyNo As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim i As Integer Dim remark As String If TheNo > 999999999999.99 Then Exit Function If TheNo = 0 Then NoToTxt = "صفر" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "أربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشر" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "أربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "واحد" MyArry3(2) = "اثنان" MyArry3(3) = "ثلاثة" MyArry3(4) = "أربعة" MyArry3(5) = "خمسة" MyArry3(6) = "ستة" MyArry3(7) = "سبعة" MyArry3(8) = "ثمانية" MyArry3(9) = "تسعة" '====================== GetNo = Format(TheNo, "000000000000.00") i = 0 Do While i < 15 If i < 12 Then MyNo = Mid$(GetNo, i + 1, 3) Else MyNo = "0" + Mid$(GetNo, i + 2, 2) End If If (Mid$(MyNo, 1, 3)) > 0 Then RdNo = Mid$(MyNo, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(MyNo, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(MyNo, 2, 1) My10 = MyArry2(RdNo) If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر" If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر" If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12 End If If (i = 0) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (i = 3) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (i = 6) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف" If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان" End If End If If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If i = i + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = remark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = remark + MyFraction + " " + MySubCur End If Else NoToTxt = remark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function استخدم هذا الكود تفقيط الارقام فى الاكسس.accdb وهذا الكود يحول من الأرقام إلى الحروف و لكن باللغة الأنجليزية و هو بالطبع بلغة الفيجوال بيسك للتطبيقات المرفقة مع قواعد بيانات أكسس و يمكنك وضع الكود في MODULE و تسميه NumberToWrod و تقوم بعمل اللازم بعد ذلك و الكود هو [B][SIZE=6][B][SIZE=3]Function ConvertCurrencyToEnglish(ByVal mynumber) Dim Temp Dim Dollars, Cents Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Thousand " Place(3) = " Million " Place(4) = " Billion " Place(5) = " Trillion " ' Convert MyNumber to a string, trimming extra spaces. If Not mynumber = Null Then mynumber = Trim(Str(mynumber)) End If ' Find decimal place. DecimalPlace = InStr(mynumber, ".") ' If we find decimal place... If DecimalPlace > 0 Then ' Convert cents Temp = Left(Mid(mynumber, DecimalPlace + 1) & "00", 2) Cents = ConvertTens(Temp) ' Strip off cents from remainder to convert. mynumber = Trim(Left(mynumber, DecimalPlace - 1)) End If Count = 1 Do While mynumber <> "" ' Convert last 3 digits of MyNumber to English dollars. Temp = ConvertHundreds(Right(mynumber, 3)) If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars If Len(mynumber) > 3 Then ' Remove last 3 converted digits from MyNumber. mynumber = Left(mynumber, Len(mynumber) - 3) Else mynumber = "" End If Count = Count + 1 Loop ' Clean up dollars. Select Case Dollars Case "" Dollars = "Zero Dirham" Case "One" Dollars = "One Dirham" Case Else Dollars = Dollars & " Dirhams" End Select ' Clean up cents. Select Case Cents Case "" Cents = " And Zero Fils Only." Case "One" Cents = " And One Fils Only." Case Else Cents = " And " & Cents & " Fils Only." End Select ConvertCurrencyToEnglish = Dollars & Cents End Function Private Function ConvertHundreds(ByVal mynumber) Dim Result As String ' Exit if there is nothing to convert. If Val(mynumber) = 0 Then Exit Function ' Append leading zeros to number. mynumber = Right("000" & mynumber, 3) ' Do we have a hundreds place digit to convert? If Left(mynumber, 1) <> "0" Then Result = ConvertDigit(Left(mynumber, 1)) & " Hundred " End If ' Do we have a tens place digit to convert? If Mid(mynumber, 2, 1) <> "0" Then Result = Result & ConvertTens(Mid(mynumber, 2)) Else ' If not, then convert the ones place digit. Result = Result & ConvertDigit(Mid(mynumber, 3)) End If ConvertHundreds = Trim(Result) End Function Private Function ConvertTens(ByVal MyTens) Dim Result As String ' Is value between 10 and 19? If Val(Left(MyTens, 1)) = 1 Then Select Case Val(MyTens) Case 10: Result = "Ten" Case 11: Result = "Eleven" Case 12: Result = "Twelve" Case 13: Result = "Thirteen" Case 14: Result = "Fourteen" Case 15: Result = "Fifteen" Case 16: Result = "Sixteen" Case 17: Result = "Seventeen" Case 18: Result = "Eighteen" Case 19: Result = "Nineteen" Case Else End Select Else ' .. otherwise it's between 20 and 99. Select Case Val(Left(MyTens, 1)) Case 2: Result = "Twenty " Case 3: Result = "Thirty " Case 4: Result = "Forty " Case 5: Result = "Fifty " Case 6: Result = "Sixty " Case 7: Result = "Seventy " Case 8: Result = "Eighty " Case 9: Result = "Ninety " Case Else End Select ' Convert ones place digit. Result = Result & ConvertDigit(Right(MyTens, 1)) End If ConvertTens = Result End Function Private Function ConvertDigit(ByVal MyDigit) Select Case Val(MyDigit) Case 1: ConvertDigit = "One" Case 2: ConvertDigit = "Two" Case 3: ConvertDigit = "Three" Case 4: ConvertDigit = "Four" Case 5: ConvertDigit = "Five" Case 6: ConvertDigit = "Six" Case 7: ConvertDigit = "Seven" Case 8: ConvertDigit = "Eight" Case 9: ConvertDigit = "Nine" Case Else: ConvertDigit = "" End Select[/SIZE] [SIZE=3]End Function[/SIZE][/B][/SIZE][/B]

ليش هاني مجدي والمنتدى مملوء ببرامج المطعم ابحث بالمنتدى (مطعم) بتحصل ماتريد ................. يوجد ملاحظة أخرى أقرأ اسفل مشاركتي ملاحظات مهمه : من استاذنا @Bluemind 1-نتيجة البحث بكلمة مطعم هنا . https://www.officena.net/ib/search/?&q=%D9%85%D8%B7%D8%B9%D9%85&type=downloads_file&quick=1&item=121275&nodes=5&search_and_or=or&sortby=relevancy 2-نتيجة البحث بكلمة Restaurant هنا . https://www.officena.net/ib/search/?&q=restaurant&type=downloads_file&quick=1&item=121275&nodes=5&search_and_or=or&sortby=relevancy

اشكر حضرتك على تبنى الفكره ومتابع مع حضرتك من خلال جروب الواتس

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

السلام عليكم ورحمة الله جرب الملف بالمرفقات وإن شاء الله ينجح معك... برنامج شهادات.xls

المعادلة تعمل بالفعل وشغالة تمام بملفك وشوف بنفسك

طيب ..شوف التعديل و خبرني النتيجة 444.rar

يجب ان نفهم ان جميع الموجود في جدول التحليل هو عبارة عن بيانات ثابتة لا تتغير وهي تصف التحليل المفترض العملية تتم كالتالي : مربع تحرير لاختيار المجموعة الرئيسية قائمة لعرض المجموعة الفرعية قائمة لعرض التحاليل التي تندرج تحت ما تم اختياره من القائمة الفرعية _____________________________ عند اختيار تحليل او اكثر ثم النقر على اضافة يتم نقل معرف التحليل (فقط) الى جدول المريض ... ويتم اكمال البيانات من خلال الفورم ملحوظة : اقصد بجدول المريض اي جدول تحاليل المريض ، حيث المفترض انه تم تسجيل المريض من قبل وتسجيل بياناته الأساسية حتى لو المريض جديد وهذه هي الزيارة الأولى اعطاء صورة او تصور اكبر (مختصر ) لكيفية تصميم (جداول) برنامج عيادات طبية 1- جداول ثابتة : أ- بيانات المريض ب- بيانات الاطباء ج- بياناتالأقسام ... وغيرها 2 - جداول خدمية ثابتة : أ - التحاليل وانواعها 2- الاشعة وانواعها ج- تحاليل سريعة (الاستقبال) 3- الادوية ... وغيرها 3- جداول فرعية متغيرة : ( مرتبطة بجدول المريض ) أ- التحاليل ونتيجته ب- الاشعة ونتيجتها 3- العلاج ( بأنواعه) وتوصيات الطبيب جميع الجداول الفرعية هذه تشتمل على معرف المريض فقط من اجل الربط مع جدول بياناته

بعيداً غن المشاركة ممكن تستفيدي من هذه المشاركة ممكن تفيدك . https://www.officena.net/ib/topic/66722-برنامج-تسجيل-التحاليل-الطبية/

شكرا لردك اخي الكريم و لكن قبل طرح استفساري هذا بحثت بالفعل في المنتدي كما ذكرتك انت سابقا و لكني لم اجد ما اريده اما بالنسبة ل "ليش هاني " ف انا صممت قاعدة البيانات هذه بعد مشاهدتي له و لارجاع الفضل لصاحبه ليس اكثر تحياتي اخي الكريم 🥰

تفضل سيتم تنفيد الكود الخاص بكل ورقة عمل عند التغيير في احدى خلايا تاريخ البداية او النهاية سواءا في ورقة 4 او 10 في module جديد انسخ الاكواد التالية Sub test1() '********************************* تقرير الاصناف Dim Sh As Worksheet: Set Sh = Sheet4 Dim Sh1 As Worksheet: Set Sh1 = Sheet6 Dim Sh2 As Worksheet: Set Sh2 = Sheet8 b = Sh1.Name: C = Sh2.Name With Application .ScreenUpdating = False .Calculation = xlManual End With Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000") Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000") Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000") With Range("G9:G" & Range("C" & Rows.Count).End(3).Row) .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$F$7,'" & b & "'!" & V2.Address & ",""<=""&$I$7,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value With Range("H9:H" & Range("C" & Rows.Count).End(3).Row) .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$F$7,'" & C & "'!" & V5.Address & ",""<=""&$I$7,'" & C & "'!" & V6.Address & ",C9)" .Value = .Value End With End With With Application .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub Sub test2() '************************ 'الجرد الشهري Dim MyRng As Range Dim Sh As Worksheet: Set Sh = Sheet10 Dim Sh1 As Worksheet: Set Sh1 = Sheet6 Dim Sh2 As Worksheet: Set Sh2 = Sheet8 b = Sh1.Name: C = Sh2.Name Set MyRng = Sh.Range("A9:M44") With Application .ScreenUpdating = False .Calculation = xlManual End With Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000") Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000") Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000") With Range("H9:H44") .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value With Range("J9:J44") .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$E$5,'" & C & "'!" & V5.Address & ",""<=""&$G$5,'" & C & "'!" & V6.Address & ",C9)" .Value = .Value End With End With MyRng.Replace 0, "", xlWhole With Application .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub في حدث ورقة 4 Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Application.ScreenUpdating = False Set V1 = Sheet4: Set V2 = Sheet10: Set V3 = Sheet11 Lr = V1.Range("C" & Rows.Count).End(xlUp).Row V2.Range("F9:F" & Lr).Value = V1.Range("F9:F" & Lr).Value V3.Range("F9:F" & Lr).Value = V1.Range("L9:L" & Lr).Value V3.Range("H9:H" & Lr).Value = V1.Range("O9:O" & Lr).Value If Intersect(Target, Range("F7:i7")) Is Nothing Then Exit Sub On Error Resume Next Application.EnableEvents = False Call test1 Application.EnableEvents = True On Error GoTo 0 Application.ScreenUpdating = True End Sub في حدث ورقة 10 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Application.ScreenUpdating = False If Intersect(Target, Range("E5:G5")) Is Nothing Then Exit Sub Application.EnableEvents = False Call test2 Application.EnableEvents = True On Error GoTo 0 End Sub

ارسل لي الملف وانا افك الحماية واعاود ارسالة لك

محاولة في المرفقات... مخطط جلوس.xlsb

Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Set V1 = Sheet4: Set V2 = Sheet10: Set V3 = Sheet11 Lr = V1.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row Application.ScreenUpdating = False V2.Range("F9:F" & Lr).Value = V1.Range("F9:F" & Lr).Value V3.Range("F9:F" & Lr).Value = V1.Range("L9:L" & Lr).Value V3.Range("H9:H" & Lr).Value = V1.Range("O9:O" & Lr).Value Application.ScreenUpdating = True End Sub

السلام عليكم ورحمه الله

كان الخلل في قراءة رقم الكتاب هذه تحدث احيانا وليست على اطلاقها .. وهي ان الكود لا يقرأ قيمة الحقل الا مع التركيز عليه لذا اخذت بالاحتياط وتم التحايل على فرق الوقت الذي تأخذه عملية المسح بين ملف وآخر ، بالاستعانة بعداد النموذج بدلا من sleep او wait وهذه هي الجمل البرمجية كاملة ... Option Compare Database Option Explicit Dim i As Integer Dim mypath As String '--------------------------------------------------------------------------------- Private Sub Form_Timer() Me.Refresh If funDirFile = 0 Then If i = 0 Then Me.bookNumber.SetFocus Shell ("c:\Program Files (x86)\irfanview\i_view32.exe /batchscan=(" & Me.bookNumber.Value & ",,,,," & mypath & " ,pdf,0) /scanhidden") i = 1 End If Else Me.TimerInterval = 0 End If Call Form_Current End Sub '---------------------------------------------------------------------- Private Sub scanpdf_Click() i = 0 Dim strFile As String, DirFile As String Me.bookNumber.SetFocus strFile = Trim(bookNumber.Value) & ".pdf" mypath = Application.CurrentProject.Path & "\My_Archive\Import\My_pdf\" DirFile = Dir(Application.CurrentProject.Path & "\My_Archive\Import\My_pdf\" & strFile) Me.TimerInterval = 3000 End Sub '--------------------------------------------------------------------------- Function funDirFile() Dim strFile As String, DirFile As String Me.bookNumber.SetFocus strFile = bookNumber.Value & ".pdf" DirFile = Application.CurrentProject.Path & "\My_Archive\Import\My_pdf\" & strFile funDirFile = Len(Dir(DirFile)) End Function '------------------------------------------------------------------------------------ Private Sub Form_Current() Dim sMyFileName As String sMyFileName = Application.CurrentProject.Path & "\My_Archive\Import\My_pdf\" & Trim(bookNumber.Value) & ".pdf" WebBrowser1.Navigate (sMyFileName) Me.Refresh End Sub test6.rar

السلام عليكم ورحمه الله وبركاته راجع الموضوع ادناه

السلام عليكم ورحمة الله وبركاته لقد أنشأت برنامج بسيط وجمعت به الأكواد التي نسنتخدمها باستمرار وصممته بحيث تكون الواجهة عبارة عن شاشة يتم تجميع بها الأكواد المراد نسخها الي شاشة الفيجوال بيسك لمشاهدة كيف يعمل البرنامج من هذا الرابط بنك الأكواد - demo-24-4-2019.accdb

كيفية اضافة معادلة البحث XLOOKUP لاوفيس 2019-2016-2013-2010-2007-2003 في الفيديو دة هاتقدر تشتغل وكأنك معاك اوفيس 365 XFunctions.7z

السلام عليكم ورحمة الله تفضل اخيى ممكن يفيدك ماكرو استدعى فورم البحث والإستبدال والخاص بالنظام تم إضافة ملفان آخران خذ منها ما يناسبك ورجع الباقي ماكرو للبحث.rar فورم لاستبدال كلمات فى صفحات محددة.rar كود رائع لإستبدال الكلمات بكلمات أخرى.rar