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

تم حل الموضوع والحمدلله

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

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

34 دقائق مضت, kkhalifa1960 said:

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

تم التعديل 

و الأمور تمام لم انتبه على الموديول ممنون

ولكن هل يمكن نقل اسم الملف والمسار في مسار الملف للفورمين 

وجعل اسم الملف (رقم الكتاب + التاريخ)

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]

1 ساعه مضت, Ahmed_J said:

السلام عليكم 

استاذ @ابوخليل

آسف على التاخير كنت مسافر

كل شيء تمام

بارك الله فيك

وشكرا لك

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

20 ساعات مضت, safaa salem5 said:

شكرا لحضرتك جزيلا 

اذا انتهت المشكلة ولله الحمد ، فقط اختر الإجابة كأفضل إجابة 

7 ساعات مضت, safaa salem5 said:

 المكان بتاع الترتيب اليومى دا هيعد لوحده ويتجدد كل يوم بمعنى تانى بداية اليوم هيعد من 1  الى ان يصل الى اخر اليوم ومع اليوم التالى يبدأ العد من اول 1 تانى

lab4.rar 245.55 kB · 5 downloads

تفضل مشاركتي اطلع عليها 

ترقيم يومي جديد.accdb

منذ ساعه, safaa salem5 said:

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

lab4.rar 245.55 kB · 1 download

تفضل 

lab4.accdb

2 ساعات مضت, Abdelaziz Osman said:

السلام عليكم  ,  مطلوب عمل كلمة مرور عند استخدام زر عرض التصميم  فى اكسيس

للاسف ماكو طريقة تضع كلمة مرور لطريقة عرض التصميم

ولكن لديك الاتي

اولا حفظ الملف بامتداد ACCDE 

ثانيا موديل اخفاء عناصر الاكسس و الغاء الشفت

2 ساعات مضت, saffar said:

السلام عليكم

يوجد فراغ بين ذيل الصفحة والتفاصيل كيف يمكن الغاء الفراغ بحيث يكون الذيل ملاصف للتفاصيل

 

stlist.accdb 464 kB · 5 downloads

وعليكم السلام

وين الفراغ ماشايف فراغ بالتقرير ؟ 

5 ساعات مضت, Ahmed_J said:

اذا كنت تعمل على برنامج للارشفة 

 

نعم اعمل عليه الآن وسيتم الانتهاء منه قريبا

5 ساعات مضت, Ahmed_J said:

من الافضل ان يظهر ملف jpg او pdf  في نموذج الاكسس

أكيد و سوف نجد حلا لهذه المشكلة ان شاء الله

5 دقائق مضت, Ahmed_J said:

الخي العزيز

قلت لك لابد من وضع (plugins)  بجانب البرنامج لكي يعمل pdf 

اما الجودة براحتك لديك خيارات جودة من (40%) الى (95%)

تحياتي

شكرا جزيلا

وجاري تطبيقها ع البرنامج

23 دقائق مضت, Ahmed_J said:

السلام عليكم

اخي زياد العزيز

الصورة الاولى خاصة باخراج الملف pdf

الصورة الثانية خاصة بالدقة

تظهر معي هذه الرسالة 

تم تنزل الاضافات 

صح ؟ الاعدادات

1 دقيقه مضت, Ahmed_J said:

السؤال الاول : يجب تثبيت  ادوبي اكروبات و (iview462_plugins) لكي يعمل pdf 

اثنينهن عندي و لكن ما زال عند السحب يتم اخذ الملفات كصور

1 دقيقه مضت, Ahmed_J said:

السؤال الثاني: يمكنك تعديل الخيارات باقل جود ممكنة 

دورت ع خيار التعديل للجودة ولم اجده

السلام عليكم

لدي المرفق التالي للاخ @الحلبي

ولكن المطلوب التعديل عليه

اولا :- يتم اخذ الملفات من السكنر وتصديرها بصيغة ال PDF وليس صورة

ثانيا :- تقليل درجة الجودة المأخوذه حيث بالملف الاعدادات الحالية اعلى دقة

HALABI _ up1 .rar

14 دقائق مضت, مصطفى العراقي1988 said:

@عمر ضاحى

استاذنا الكريم اشكرك جزيل الشكر للاجابة 

فعلاً الطريقة ناجحة 

لكن هناك عناوين وظيفية اخرى غير متشابهة 

جزاك الله خير الجزاء

حسب ما فهمت منك

لابد من عمل فورم يوجد فيه قائمة منسدلة مصدرها العناوين الوظيفية

وعند التنفيد يكون مصدره الاستعلام و المعيار يكون

[X]![nameform]! [FORM]

حيث الاكس هو اسم الكومبوبوكس في الفورم

1 ساعه مضت, مصطفى العراقي1988 said:

استاذ @زياد الحسناوي

عندي بعد عناوين اضافية تقريباً 60 عنوان اضافي 

وبخانة الكويري موجودة بس 9 خانات 

اكو طريقة اكدر اضيف بيهه بعد خانات ؟

سؤال ؟ حيرني وما لكيت اله اجابة 

ليش خليت العنوانين بهالطريقة بالكويري ؟ 

19 دقائق مضت, شايب said:

بل يعمل اخي

الملف مرفق

 

 

Database1(19).accdb 404 kB · 2 downloads

تمام مضبوط ولكن توجد مشكلة ال ID بأخذ رقم جديد وعند مسح المعلومات يبدأ من رقم آخر

18 دقائق مضت, kkhalifa1960 said:

تفضل أخي ولو في أي طلب آخر وافني به .

Database1-2.accdb 576 kB · 2 downloads

تمام مضبوط ولكن توجد مشكلة ال ID بأخذ رقم جديد وعند مسح المعلومات يبدأ من رقم آخر

3 دقائق مضت, مصطفى العراقي1988 said:

نعم تم حل المشكلة بنجاح استاذ 

بالخدمة أخي

36 دقائق مضت, شايب said:

استخدم دالة العد

في حدث بعد التحديث لحقل الجهة او في زر امر او في الحدث الذي تراه مناسب لبرنامجك ضع الامر التالي

Dim x As Integer
x = DCount("*", "table1", "[num]=" & [Num] & "and [from]='" & [From] & "'")
If x > 1 Then
If MsgBox("هذه القيمة مسجلة مسبقا", vbYesNo, "تكرار") = vbYes Then
DoCmd.CancelEvent
Me.Undo
Else
End If
End If

الشايب

شكرا جزيلا تم التجربة على زر والامور تمام ولكن عند وضع الكود بحدث بعد التحديث لا يعمل 

6 دقائق مضت, kkhalifa1960 said:

تفضل أخي محاولتي .

Database1-1.accdb 576 kB · 0 downloads

عاشت ايدك أخي تمام التمام ولكن يجب تغيير اضافة جديد الى كود برمجي وليس مايكرو لان لو تكررت المعلومات ولم اضغط على الحفظ سيحفظ الجدول حتى ولو كان متكرر

2 دقائق مضت, مصطفى العراقي1988 said:

السلام عليكم ورحمة الله وبركاته

 

اخواني الاعزاء اريد انشاء كويري تبدأ بهذا التسلسل

 

م.مهندس - مهندس - مهندس اقدم - م.ر مهندسين - ر.مهندسين - ر.مهندسين اقدم 

 

ولكن الاكسس يقوم بتحويل كلمة ( م.مهندس الى  (م) و (مهندس) على انها كلمتين وليست كلمة واحدة 

ماهو الحل في هذه الحالة 

شكراً جزيلاً لكم 

قم بتحويل مم.مهندس الى م_مهندس مثلا او م-مهندس

السلام عليكم

عندي حقلين الاول رقم والثاني الجهة

في حالة تكرار الرقم و من نفس الجهة يظهر تحذير 

مثلا حاليا شركة الرماح تملك رقم 100 مرتين 

Database1.accdb