ابو جودي

اهلا اهلا اهلا استاذى الجليل واخى الحبيب ليست فكرتى اصلا ولكن المرفق من اخراجى الاصل والاساس هو توجيه من استاذى القدير ومعلمى الجليل ووالدى الحبيب الاستاذ @ابوخليل اهدانيها ذات يوم

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

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

ممكن قاعدتك التى تحتوى على هذه المشكله

يا الهى 60 نموذج العمل على هذا العدد من النماذج حتما لن يكون سهل هذا اذا ما اضفنا اليه عدد المستخدمين انظر يا استاذ @محمد صلاح1 اولا انا كنت اعمل على اعذداد مشروع ضخم بهذا الصدد اخذا فى الاعتبار كل التفاصيل الكبيرة منها والصغيرة التى تعملتها على ايد اساذتى الكرام وعلى رأسهم التبيهات التى ظل استاذى الجليل ومعلمى القدير الاستاذ @jjafferr بارك الله لنا فيه ورزقه كل الخير ان شاء الله - سهولة التعديل على اعداد القاعدة بمرونه من ال end users بدون الذهاب الى الاكواد - عدم استخدام الرسائل العربية مطلقا بأى شكل من الأشكال داخل محرر الاكواد اولا هتان النقطتان اتعبانى جدا جدا جدا جدا جدا وكانوا سببا رئيسيا فى تأخير هذا العمل ولازال قيد الدراسة والتصميم كما اخذت فى الاعتبار وضع كل المتطلبات التى وجدتها بهذا الصدد واضفت افكارى الشخصية وافكار اخوانى التى حصرتها من طلباتهم ان اردت الانتظار ابشر سأضع العمل كله ان شاء بين اياديكم فور انتهائى ولكن لا استطيع تحديد موعد نظرا لحالتى الصحية فى الوقت الراهن فكما تلاحظون مشاركاتى وتواجدى قليل جدا لاننى غير مسموح لى بالجلوس لفترات كبيرة او الثبوت على وضع محدد كذلك وهذا خارج عن ارادتى ان كنت على عجل من امرك انصحك بالتفطير فى تسجيل المستخدمين وادراجهم وتنسيبهم الى مجموعات عمل وكل مجوهة تأخذ الاذونات الى تلائمها بذلك فقط اعتذ لن تطون مضطرا الى التعامل مع كل خذا العدد من النماذج هذا ما بنيت قاعدتى عليه والتى ستكون ان شاء الله بين اياديكم قريبا بامر الله

اتفضل اعتقد طلبك هنا Option Compare Database Option Explicit Public Const vArabic As Byte = 1 Public Const vEnglish As Byte = 2 Public Const vMale As Byte = 0 Public Const vFemale As Byte = 1 Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null) myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue) End Function '******************************************************************************* Private Function Delete(S As String, Index As Integer, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Private Function Insert(Source, S As String, Index As Integer) As String Dim LPart As String Dim RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function '******************************************************************************* Private Function AddAnd(S1 As String, S2 As String, S3 As String, _ And_ As String, Lang As Byte) As String Dim InAnd_ As String Dim CollectS As String If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " " If (S1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = "" CollectS = S1 + And_ + S2 If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = "" AddAnd = CollectS + And_ + S3 End Function '******************************************************************************* Private Function S2Double(Single_ As Variant, Sex As Byte) As String Dim LLeter As Integer Dim K As Byte Dim Sngl_1 As String Dim Sngl_2 As String K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تان" Else Sngl_2 = Sngl_2 & "ان" End If End If If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1)) Select Case LLeter Case 201 ' "ة" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تان" Case 236 ' "ى" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يان" Case 199 ' "ا" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان" Case 193 ' "ء" If Right(Sngl_1, 2) = "اء" Then If Sex = 1 Then Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان" Else Sngl_1 = Sngl_1 & "ان" End If End If Case Else If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "ان" End Select If Sngl_2 <> "" Then S2Double = Sngl_1 & " " & Sngl_2 Else S2Double = Sngl_1 End If End Function '******************************************************************************* Private Function Fmale(Num As Byte, Sex As Byte, Female()) As String Dim Two(1 To 4) As String Dim InSex As Byte Two(1) = "أحد" Two(2) = "اثنان" Two(3) = "إحدى" Two(4) = "ة" Select Case Sex Case vMale: Select Case Num Case 1: Fmale = Mid(Female(1), 1, 4) Case 2: Fmale = Two(2) Case 8: Fmale = Female(Num) + "ي" + Two(4) Case 3 To 7, 9, 10: Fmale = Female(Num) + Two(4) Case 11: Fmale = Two(1) + " " + Female(10) Case 12: Fmale = Mid(Two(2), 1, 4) + " " + Female(10) Case 13 To 19: Fmale = Female(Num - 10) + Two(4) + " " + Female(10) End Select Case vFemale: Select Case Num Case 1 To 10: Fmale = Female(Num) Case 11: Fmale = Two(3) + " " + Female(10) + Two(4) Case 12: Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4) Case 13 To 19: Fmale = Female(Num - 10) + " " + Female(10) + Two(4) End Select End Select End Function '******************************************************************************* Private Function Tens(Num As Byte, Female()) As String Const Noon = "ون" Select Case Num Case 2: Tens = Female(10) + Noon Case 3 To 9: Tens = Female(Num) + Noon End Select End Function Private Function Hunds(Num As Byte, Female()) As String Const Hund = "مائة" Select Case Num Case 1: Hunds = Hund Case 2: Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3) Case 3 To 9: Hunds = Female(Num) + Hund End Select End Function Private Function Tenteen(Num As Byte, ETens()) As String Const een = "een" Num = Num Mod 10 Select Case Num Case 3 To 9: Tenteen = Mid(ETens(Num), 1, Len(ETens(Num)) - 1) + een End Select End Function '******************************************************************************* Private Function EHunds(Num As Byte, ESingle()) As String EHunds = ESingle(Num) + " hundred" End Function '******************************************************************************* Private Function ReFormat(InNum As Double, Dec As Byte) As Double Dim NewFormat As String If Dec > 0 Then NewFormat = "0." Else NewFormat = "0" NewFormat = NewFormat & String(Dec, "0") ReFormat = Format(InNum, NewFormat) End Function '******************************************************************************* Private Function ReStr(InNum As String) As String Dim K As Byte Dim Digits As Byte Dim Num_ As String Num_ = LTrim(InNum) K = InStr(1, Num_, "E+", 1) If K > 0 Then Digits = Val(Mid(Num_, K + 2, 3)) Num_ = Left(Num_, K - 1) Num_ = Delete(Num_, 2, 1) Do While Len(Num_) - 1 < Digits Num_ = Insert(Num_, "0", 1) Loop End If ReStr = Num_ End Function '******************************************************************************* Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String Const And_ As String * 1 = "و" Const Lang = vArabic Dim PartNum(0 To 5) As Long Dim Result1(0 To 5) As String Dim Parts_(0 To 11) As String Dim Female(1 To 10) As Variant Dim TempI As Byte Dim Sex2 As Byte Dim K As Byte Dim Only_ As String Dim OnlyPart As String Dim Part_ As String Dim TempS As String Dim Sngl_1 As String Dim Sngl_2 As String Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then AOnly = RTrim("لا شيء " & Single_) Else AOnly = FracS & " " & Single_ End If Exit Function End If Female(1) = "واحدة" Female(2) = "اثنتان" Female(3) = "ثلاث" Female(4) = "أربع" Female(5) = "خمس" Female(6) = "ست" Female(7) = "سبع" Female(8) = "ثمان" Female(9) = "تسع" Female(10) = "عشر" Parts_(0) = "" Parts_(1) = "ألف" Parts_(2) = "مليون" Parts_(3) = "مليار" Parts_(4) = "ترليون" Parts_(5) = "كدرليون" Parts_(6) = "" Parts_(7) = "آلاف" Parts_(8) = "ملايين" Parts_(9) = "مليارات" Parts_(10) = "ترليونات" Parts_(11) = "كدرليونات" K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K Sex2 = Sex For K = 0 To (Parts - 1) If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = Hunds(CByte(N1), Female()) If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1) Select Case TempI Case 1 To 2: If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female()) 'Sex Case 3 To 19: N3_ = Fmale(TempI, CByte(Sex), Female()) Case 20 To 99: N2_ = Tens(CByte(N2), Female()) If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female()) If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدى" End Select OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang) '{------------------------------------------} If PartNum(K) > 100 Then Select Case TempI Case 1, 2: OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang) End Select End If '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = Parts_(Parts - K - 1) If Part_ <> "" Then Select Case TempI Case 2: Part_ = Part_ + "ان" Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 6) Case 11 To 99: Part_ = Part_ + "ا" End Select End If End If '{------------------------------------------} If Part_ <> "" Then If TempI >= 1 And TempI <= 2 Then OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang) Else OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang) End If End If Result1(K) = (OnlyPart) Next K '{------------------------------------------} N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang) N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang) Only_ = AddAnd(N1_, N2_, "", And_, Lang) If FracS <> "" Then If Only_ <> "" Then FracS = " " + FracS Only_ = AddAnd(Only_, FracS, "", And_, Lang) End If If Only_ <> "" Then If Mid(Only_, Len(Only_), 1) = "ا" Then If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If If TempS = "000" Then If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If End If '{------------------------------------------} If FracS = "" Then Select Case TempI Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 3 To 10: If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang) Else Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang) End If Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If Case 11 To 99: If Sngl_1 <> "" Then Only_ = AddAnd(Only_, Sngl_1, "", "", Lang) N1_ = Mid(Only_, Len(Only_), 1) Select Case N1_ Case "ة", "ى", "ا" Case Else Only_ = Only_ + "ا" End Select N1_ = Mid(Only_, Len(Only_) - 2, 3) 'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24 If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then Only_ = Left(Only_, Len(Only_) - 1) End If If Sngl_2 <> "" Then If Right(Only_, 1) = "ا" Then Only_ = AddAnd(Only_, Sngl_2 & "ا", "", "", Lang) Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If End If End Select Else Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang) End If AOnly = (Only_) End Function '******************************************************************************* Private Function EOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Dec As Byte) As String Const Lang = vEnglish Dim ESingle(1 To 12) As Variant Dim ETens(2 To 9) As Variant Dim EParts_(0 To 5) As String Dim PartNum(0 To 5) As Long Dim Result1(0 To 5) As String Dim TempS As String Dim TempI As Byte Dim Sex2 As Byte Dim OnlyPart As String Dim Part_ As String Dim Only_ As String Dim Leng As Integer Dim K As Integer Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then 'EOnly = LTrim(Single_ & " zero") EOnly = RTrim("zero " & Single_) Else EOnly = Single_ & " " & FracS End If Exit Function End If ESingle(1) = "one" ESingle(2) = "two" ESingle(3) = "three" ESingle(4) = "four" ESingle(5) = "five" ESingle(6) = "six" ESingle(7) = "seven" ESingle(8) = "eight" ESingle(9) = "nine" ESingle(10) = "ten" ESingle(11) = "eleven" ESingle(12) = "twelve" ETens(2) = "twenty" ETens(3) = "thirty" ETens(4) = "forty" ETens(5) = "fifty" ETens(6) = "sixty" ETens(7) = "seventy" ETens(8) = "eighty" ETens(9) = "ninety" EParts_(0) = "" EParts_(1) = "thousund" EParts_(2) = "million" EParts_(3) = "billion" EParts_(4) = "trillion" EParts_(5) = "quadrillion" For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K For K = 0 To (Parts - 1) TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = EHunds(CByte(N1), ESingle()) Select Case TempI Case 1 To 12: N3_ = ESingle(TempI) Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), ETens()) Case 20 To 99: N2_ = ETens(N2) If N3 > 0 Then N3_ = N2_ + "-" + ESingle(N3) N2_ = "" End If End Select OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang) '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = EParts_(Parts - K - 1) If Part_ <> "" Then Part_ = EParts_((Parts - K - 1)) End If Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang) Next K '{------------------------------------------} N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang) N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang) Only_ = AddAnd(N1_, N2_, "", "", Lang) Leng = Len(Only_) Only_ = AddAnd(Only_, FracS, "", " and", Lang) If Only_ <> "" Then 'Only_ = AddAnd(Single_, Only_, "", "", Lang) If Val(Num_) = 1 Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If EOnly = Only_ End If End Function Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant Dim Num_ As String Dim K As Byte Dim Dec As Byte Dim FType As Byte If IsNull(InNum) Then S_Only = Null Exit Function End If Num_ = Str(InNum) K = InStr(1, Num_, ".", 1) If K > 0 Then Dec = Len(Num_) - K If Dec < 2 Then Dec = 2 Else Dec = 0 End If FType = FracType If FType <> 2 Then FType = 1 S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType) End Function '******************************************************************************* Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _ Single_ As String, Plural As String, _ FSex As Byte, SFrac As String, PFrac As String, _ FracType As Byte) As Variant Dim Leng As Byte Dim Parts As Byte Dim K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS As String Dim FracNum As String Dim Only As String Dim And_ As String If IsNull(InNum) Then B_Only = Null Exit Function End If Num_ = Str(InNum) If InStr(1, Num_, "E+", 1) > 0 Then Num_ = ReStr(Num_) FracVal = 0 GoTo DoProcess End If Num_ = ReFormat(Val(InNum), Dec) K = InStr(1, Num_, ".", 1) If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = "" FracVal = Val(FracS) Num_ = Trim(Str(Fix(InNum))) Do While Len(FracS) < Dec + 2 FracS = Insert(FracS, "0", 1) Loop DoProcess: If FracVal = 0 Then FracS = "" FracNum = Trim(Mid(FracS, 3, Len(FracS))) If FracS <> "" Then Select Case FracType Case 2 Select Case Lang Case vArabic: FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0"))) Case vEnglish: FracS = CDbl(Format(FracNum, String(Dec, "0"))) & "/" & "1" & String(Dec, "0") End Select Case 3 FracS = CLng(FracNum) & " " & SFrac 'If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "(s)" Case 4 Leng = Len(FracNum) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng FracNum = Insert("0", FracNum, 1) Next K Select Case Lang Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType) Case vEnglish: 'FracS = EOnly(FracNum, "", "", "", Parts, 0) & " " & SFrac FracS = EOnly(FracNum, "", SFrac, PFrac, Parts, 0) '& " " & SFrac 'If CDbl(FracNum) > 1 Then FracS = FracS & "(s)" End Select End Select End If Leng = Len(Num_) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng Num_ = Insert("0", Num_, 1) Next K If Len(Num_) > 18 Then B_Only = InNum Exit Function End If Select Case FracType Case 1, 2 Select Case Lang Case vArabic: Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec) Case vEnglish: Only = EOnly(Num_, FracS, Single_, Plural, Parts, Dec) End Select Case 3, 4 Select Case Lang Case vArabic: Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracType = 3 Then And_ = "و " Else And_ = "و" If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang)) Case vEnglish: Only = EOnly(Num_, "", Single_, Plural, Parts, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracS <> "" Then Only = AddAnd(Only, FracS, "", " and", CByte(Lang)) End Select End Select If Only <> "" Then Select Case Lang 'Case vArabic: B_Only = "لا غير " & Only Case vArabic: B_Only = Only & " لا غير" 'Case vEnglish: B_Only = Only & " only" Case vEnglish: B_Only = "Only " & Only End Select End If End Function '******************************************************************************* '===========================asoft====================== Function ArbNum(ByVal InNum, _ Optional ByVal DecimalPlaces, _ Optional ByVal FractionType, _ Optional ByVal CurrencySingle, _ Optional ByVal CurrencyPlural, _ Optional ByVal CurrencySex, _ Optional ByVal FractionSingle, _ Optional ByVal FractionPlural, _ Optional ByVal FractionSex) As Variant DecimalPlaces = Nz(DLookup("[cpro]", "tbl_curr", "[def] = true"), 2) FractionType = 4 CurrencySingle = Nz(DLookup("[currNames]", "tbl_curr", "[def] = true"), "(عملة غير معرفة)") CurrencyPlural = Nz(DLookup("[currNamep]", "tbl_curr", "[def] =true"), "(عملة غير معرفة)") CurrencySex = 0 FractionSingle = Nz(DLookup("[ProName]", "tbl_curr", "[def] = true"), "(كسر غير معرف)") FractionPlural = Nz(DLookup("[ProNamep]", "tbl_curr", "[def] = true"), "(كسر غير معرف)") FractionSex = 0 ArbNum = "فقط" & " " & B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) '----------------------------------- If CStr(myNz(CurrencySingle)) = "درجة" And _ CStr(myNz(FractionSingle)) = "جزء" Then Dim Grade As String Dim FracS As String Dim Pos As Integer DecimalPlaces = Nz(DLookup("[cpro]", "tbl_curr", "[def] = true"), 2) FractionType = 3 CurrencySingle = Nz(DLookup("[currNames]", "tbl_curr", "[def] = true"), "(عملة غير معرفة)") CurrencyPlural = Nz(DLookup("[currNamep]", "tbl_curr", "[def] =true"), "(عملة غير معرفة)") CurrencySex = 1 FractionSingle = Nz(DLookup("[ProName]", "tbl_curr", "[def] = true"), "(كسر غير معرف)") FractionPlural = Nz(DLookup("[ProNamep]", "tbl_curr", "[def] = true"), "(كسر غير معرف)") FractionSex = 0 '========================================xxx===============xxx============== Grade = B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) Case 0: Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "فقط ربع درجة لا غير", "ربع لا غير") Case 0.5: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "فقط نصف درجة لا غير", "نصف لا غير") Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "فقط ثلاثة أرباع درجة لا غير", "ثلاثة أرباع لا غير") Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " لاغير" End Select If FracS <> "" Then Pos = InStr(1, Grade, " و ") If Pos > 0 Then Grade = Left(Grade, Pos + 1) & FracS Else Grade = FracS End If End If Pos = InStr(1, Grade, "درجة واحدة لاغير") If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11) Pos = InStr(1, Grade, "درجتان اثنتان لا غير") If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14) If CDbl(myNz(InNum)) = 0 Then Grade = "لا شيء" ArbNum = "فقط" & " " & Grade End If End Function '===========================asoft====================== Function ArbNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = Null, _ Optional ByVal FractionType = 1, _ Optional ByVal CurrencySingle = "", _ Optional ByVal CurrencyPlural = "", _ Optional ByVal CurrencySex = 0, _ Optional ByVal FractionSingle = "", _ Optional ByVal FractionPlural = "", _ Optional ByVal FractionSex = 0) As Variant Dim Negative As String If IsNull(InNum) Then ArbNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "سالب " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces)) End If ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 3 If InNum <> Fix(InNum) Then If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If ArbNum2Text = Negative & _ B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) '----------------------------------- If CStr(myNz(CurrencySingle)) = "درجة" And _ CStr(myNz(FractionSingle)) = "جزء" Then Dim Grade As String Dim FracS As String Dim Pos As Integer '========================================xxx===============xxx============== Grade = Negative & _ B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) Case 0: Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ربع درجة لا غير", "ربع لا غير") Case 0.5: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "نصف درجة لا غير", "نصف لا غير") Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ثلاثة أرباع درجة لا غير", "ثلاثة أرباع لا غير") Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " لا غير" End Select If FracS <> "" Then Pos = InStr(1, Grade, " و ") If Pos > 0 Then Grade = Left(Grade, Pos + 1) & FracS Else Grade = FracS End If End If Pos = InStr(1, Grade, "درجة واحدة") If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11) Pos = InStr(1, Grade, "درجتان اثنتان") If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14) If CDbl(myNz(InNum)) = 0 Then Grade = "لا شيء" ArbNum2Text = Grade End If '-- نهاية التعديل ------------------------------------------------------- End Function '******************************************************************************* Function EngNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = Null, _ Optional ByVal FractionType = 1, _ Optional ByVal CurrencySingle = "", _ Optional ByVal CurrencyPlural = "", _ Optional ByVal FractionSingle = "", _ Optional ByVal FractionPlural = "") As Variant Dim Negative As String If IsNull(InNum) Then EngNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "Negative only " Else Negative = "Only " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencyPlural) = Empty Then CurrencyPlural = CurrencySingle '& "(s)" If myNz(FractionPlural) = Empty Then FractionPlural = FractionSingle '& "(s)" If myNz(CurrencySingle) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces)) End If EngNum2Text = Negative & S_Only(InNum, vEnglish, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 3 If InNum <> Fix(InNum) Then If myNz(FractionSingle) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If EngNum2Text = Negative & Mid( _ B_Only(CDbl(myNz(InNum)), vEnglish, 0, _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), 0, _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))), 6) End Function كما انني اعتقد ان طلبك هنا كذلك فى هذا الموضوع ايضا

اتفضل اتمنى اكون وفقت فى فهم طلبك Move files.zip

1- تنازلي.accdb

قطعا انا احب التعامل قدر الأمكان مع select case بدلا من if طبعا انا بالرد الاول اجبت بـ DO WHILE لانه كان محور التساؤل اصلا ولكن اثراء للموضوع اضفت كل الافكار التى دارت بخلدى حول هذا الموضوع طبعا من بعدكم استاذى الحبيب

اعتذر للتأخير فى الرد عليكم العفو منكم استاذى الكريم واخى الحبيب الاستاذ @kha9009lid انا اقل طالب علم فى المنتدى طيب ان اردت الافكار جميعا والتى تدور بخلدى حول هذه النقطه ووفقا لمثالكم الاطثر من رائع الفكرة الأولى من خلال SELECT CASE , DO WHILE Select Case Nz(Me.الكمية, "") Case "" Me![الكمية].SetFocus MsgBox "حقل الكمية مطلوب" Exit Sub Case Is <= 0 Me![الكمية].SetFocus MsgBox "لا يمكن معالجة هذه الكمية" Exit Sub Case Is > 0 Dim i As Integer i = [الكمية] + 1 Do While i = i i = i - 1 If i = 0 Then Exit Do Me.رقم = i Me.الموقع = i Me.المدينة = "القاهرة" DoCmd.GoToRecord , , acNext Loop End Select الفكرة الثانية If IsNull([الكمية]) Then MsgBox "حقل الكمية مطلوب" Me.الكمية.SetFocus Exit Sub Else Dim i As Integer i = [الكمية] + 1 Do While i = i i = i - 1 If i = 0 Then Exit Do Me.رقم = i Me.الموقع = i Me.المدينة = "القاهرة" DoCmd.GoToRecord , , acNext Loop End If

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

اخى الحبيب واستاذى الكريم @د.كاف يار جزاكم الله تعالى خيرا على دعائكم المبارك اشهد الله تعالى انى احبكم فى الله حبا خالصا لوجهه تعالى

شوف قبل فترة تقريبا اتى احد الاعضاء الكرام بمثال اجنبى تقريبا حسب قوله كنت وقتها اتجهز لاجراء العمليه ولم يسعنى التعامل والتحليل للمرفق سأتيك به هو يعتمد على نفس المكتبة التى قمت انت باستخدامها يا استاذى العزيز @د.كاف يار ولكن اعتقد تقريبا كانت مشكلة اخونا الحبيب صاحب السؤال انه عند مسح كل ورقه تأتيه رساله هل تريد مسح ورقة اخرى وكان يريد الغاء الرساله ليتم المسح لكل الاوراق مهما كان عددها دون هذه الرساله المزعجة له مع كل ورقة لم يسعنى وقتها التعامل مع المرفق واصدقكم القول الان كذلك لا يسعنى الوقت الازم ولا الادوات اللازمة للتجربة ولا الحالة الصحية فى الوقت الراهن للتحليل والتطوير ولكن ارفق اليكم المرفق عل الله يجعل الخير على ايديكم هذا رابط الموضوع

جزاكم الله خيرا اخى الحبيب واستاذى الفاضل

وعليكم السلام اتفضل استاذ @عبد الله قدور Dim i As Integer i = 6 Do While i < 10 i = i - 1 If i = 1 Then Exit Do MsgBox "The value of i is : " & i Loop طبعا غير انت ما يلزمك حسب قاعدتك انا اعطيتك الفكرة بشكل عام

لا تكمن المشكله فى صورة واحدة فقط انما مع مسح اكثر من ورقة دفعة واحدة adf Automatic Document Feeder

حبيبى الدكتور حلبي والله انى احبكم فى الله ولوجه الله تعالى وانتم نور منتدانا الحبيب ونور حياتنا اسال الله ان لا يحرمنا هذا الجمع الطييب والحب فيه ولوجه

وهذا ما تريده على مرفق استاذى الحبيب واخى الاستاذ @صالح حمادي ولكن لم اضف ال gif لانها لن تتحرك إضافة و حذف مرفقات.accdb

وذلك تعديل جديد لعرض الشعار فى كل زوايا القاعدة imgLogo.Picture = MyLogo() على ان يتم استبدل كلمة imgLogo باسم عنصر التحكم الخاص بالصورة كما تسميه انت Logo Company (Up 3).mdb

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

اعتذر ما قدمته فى المرفق كان التصور الذى جال بخاطرى انا ولم انتبه للمناقشات التى دارات مع استاذى الحبيب وتقريبا بفضل الله كل شئ موجود وهذا فقط ما كان ينقص المرفق حيث تم تعديل الكود ليتم التصفية فقط على الصور دون غيرها اثناء تغير صورة الشعار Logo Company (Up 2).mdb

واثراء للموضوع طالما سبقنى استاذى الجليل الاستاذ @صالح حمادي هذه فكرة على طريقة استاذى الجليل ومعلمى القدير الاستاذ @jjafferr حمل الصورة داخل القاعدة وليس مرفق والقاعدة المرفقة بتنسيق 2003 افتح القاعدة فى مجلد فارغ ولاحظ وجود الشعار فى النموذج اذهب للمجلد الذى وضعت به القاعدة تجد مجلدات تم اضافتها وبداخلها الشعار امسح الشعار وقم باغلاق وفتح القاعدة وشاهد السحر قم بتغيير الشعار مهما كان اسمه ومهما كانت صيغة الملف jpg . png bmp ارجع الى المجلدات تجد الشعار الجديد وحذف القديم واستبداله داخل القاعدة مهما كان اسم الشعار دون ادنى تدخل من المستخدم Logo Company.mdb اعتذر للتأخير كان وقت الصلاة

ابشر ان شاء الله الان سوف اقوم بتجهيز القاعدة المطلوبة بعد قليل اوافيكم بما يشرح فؤادك

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

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