زياد الحسناوي

شكرا جزيلا على الرد ولكن في هذه الحالة اذا كان هناك اكثر من سنة ولتكن 2023 - 2024 -2025 لا يتم فصل السنوات وسيكون النموذج مستمر من بداية البرنامج الى اليوم الحالي كما في التجربة ادناه تم الوصول الى الحل عن طريق كود VBA في الكومبوبوكس في حدث عند التغيير Database4 (4).accdb

وعليكم السلام استاذي العزيز @Ahmed_J الموضوع اصبح الان اسهل عن طريق تطبيق اندرويد خاص بالتقاعد البرنامج منذ 2019 و صراحة كنت قد نسيته اصلا ولكنه شغال 100%

السلام عليكم قاعد بيانات تحتوي على جدول فيه حقل تاريخ المطلوب احتساب كم قيد تم تسجيله خلال الايام (كل يوم على حدى ) و خلال الاشهر (كانون الثاني - شباط - اذار - نيسان) ... الخ النتيجة تظهر من خلال نموذج وليس تقرير يوجد نموذج لاظهار الاعداد للاشهر ولكن توجد مشكلة في كود الدالة عند تحديد الشهر Database4.accdb

وهو المطلوب عاشت ايدك استاذي الفاضل جاري التطبيق على الملف و اخبارك بالنتائج

شكرا لك ولكني اريد الموضوع يتممن دون مربع نص فقط الكومبوبوكس الخاص بالقائمة المنسدلة

بمعنى آخر كيفية عمل قائمة منسدلة يمكن البحث فيها

السلام عليكم هل يمكن فلترة النتائج عن طريق قائمة منسدلة يعني عندي قائمة منسدلة وفيها اكثر من 100 حقل لما اكتب اول حرف يظهر لي الاسم ولكني اريدها عند كتابة اي جزء من الاسماء تعمل فلترة حسب الاسم سواء كان في البداية او النصف او النهاية

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

تم التعديل و الأمور تمام لم انتبه على الموديول ممنون ولكن هل يمكن نقل اسم الملف والمسار في مسار الملف للفورمين وجعل اسم الملف (رقم الكتاب + التاريخ) NewScan.accdb

السلام عليكم عندي مشكلة بالنموذج FScanSader يتم فتح اولا النموذج QSaderK ومن ثم زر المرفقات لفتح الفورم اعلاه ولكن تظهر المشكلة الاتية NewScan.accdb

السلام عليكم تم نقل الاكواد ولكن توجد مشكلة بـ انشاء المجلد اولا ثانيا بتسجيل اسم الملف (رقم الكتاب + التاريخ) مثلا 124 6-11-2023 حيث 124 هو رقم الكتاب و 6-11-2023 التاريخ ثالثا بالسحب من السكنر NewScan.accdb

Up جربت انقل الاكواد واعدل عليها بس للاسف بدون فائدة

السلام عليكم الملف الاول OldScan.accdb يوجد فيه اكواد خاصة بالسكنر و سحب الملفات من الهارد مع تغير الاسم و حفظها في مجلد معين المطلوب تطبيق الاكواد على القاعدة الجديد NewScan.accdb بحيث عند سحب السكنر او ادراج ملفات يتم حفظها بناءا على رقم الكتاب و التاريخ

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]

أردت تجربة الملف المرفق ولكن ظهرت المشاكل التاليىة