مساعد فى تفقيط الارقام (تفقيط ارقام)

[بوحماد]

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

تقبل الله صيامك وجميع اعضاء أوفيسناو بمزيد من الأجر والثواب

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

Only six hundred and thirty dinars, and one hundred and thirty dirham

10330.rar

تم تعديل نوفمبر 4, 2011 بواسطه الحسامي

[أيسم إبراهيم]

السلام عليكم

أخي الكريم

تفضل المرفق يمكن يكون به ما تريد

دمت بخير

أيسم إبراهيم

تفقيط.rar

[بوحماد]

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

تقبل الله صيامك أيسم إبراهيم وجميع اعضاء أوفيسناو بمزيد من الأجر والثواب

المشلة فى العالمة العشرية تظهر خنتان مثلا 100.650 Only Hundred Dinar SixtyFive Derham

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

[بوحماد]

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

حولت التوضيح نرفق لكم الملف

10330.rar

[مصطفى كمال]

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

تقبل الله صيام وقيام الجميع بمزيد من الأجر والثواب

أخي الكريم bast وجدت لك ماكرو تحول الأرقام للانجليزي لكن بالدولار والسنت

رجاثي في باقي الإخوة المتخصصين في ٍٍِVBA تحويلها لتتوافق مع كل العملات

الماكرو موجودة في module1

بالتوفيق أخي الكريم bast

10330.rar

[مصطفى كمال]

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

تقبل الله صيام وقيام الجميع بمزيد من الأجر والثواب

أخي الكريم أيسم مبروك الترقية وطلباتك أوامر

تفضل الملف المرفق

10330.rar

[أيسم إبراهيم]

السلام عليكم

أخي مصطفى

بارك الله فيك و جزاك كل خير وشكرا على التهنئة

لكن

الملف المرفق لا يوجد به موديول كود دالة التفقيط.

أرجو مراجعة رفع المكلف بعد إذنك

دمت بخير

أيسم إبراهيم

[مصطفى كمال]

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

تقبل الله صيام وقيام الجميع بمزيد من الأجر والثواب

أخي الكريم أيسم تفضل الملف التالي يوضح لك أين تجد الدالة في الملف

module.rar

[أيسم إبراهيم]

السلام عليكم

أخي مصطفى

الملف الذي أرفقت به نسختان الأولى 2010 و الثانية 2003

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

no modules.bmp

[بوحماد]

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

استاذنا أيسم ابراهيم ممكن تضع ملف من عندك وتضع فية الكود او الدالة التى تحول بالطريقة اتى انا شرحتها ثم اقوم انا بوضع الكود او الدالة فى الملف الموجود لديا :: 630.130 Only six hundred and thirty dinars, and one hundred and thirty dirham اخى أيسم انا فى انتظر الراد لاننى بحاجة ماسة الى هذة الدالة تحياتى

[مصطفى كمال]

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

تفضل أخي الكريم أيسم الملف المرفق قد يساعدك

رجاء أخي الكريم BSAT ألق نظرة على الملف

10330.rar

[مصطفى كمال]

أخي الكريم أيسم يبدو أن الملف المرفق يحتوي بداخله ماكرو كنظام حماية

فعند تشغيل الملف تظهر رسالة خطأ ثم عند إعادة تشغيل الاكسيل يتم حذف وحدة الماكرو كليا

لا أعرف ما السبب

قمت بمحاولة بدائية على Module باستخدام بحث استبدال يمكن تغيير العملة وأجزاؤها

أرجو التوفيق مم قمت به

إليك أخي أيسم كود دالة تحويل من عربي إلى انجليزي بالنسبة لعملة الدولار

 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.


         MyNumber = Trim(Str(MyNumber))




         ' 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 = "No Dollars"


            Case "One"


               Dollars = "One Dollar"


            Case Else


               Dollars = Dollars & " Dollars"


         End Select




         ' Clean up cents.


         Select Case Cents


            Case ""


               Cents = " And No Cents"


            Case "One"


               Cents = " And One Cent"


            Case Else


               Cents = " And " & Cents & " Cents"


         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


End Function


 

[بوحماد]

مشكور اخى مصطفى الملف الذى رفقتة فية مشلكة واحدة هى ان الدارهم لايكتبها تامة ياخذ االخنتان الاولى والثانية مثلا نكتب 100.300 تظهر One Hundred Dinars And Thirty Dirham

ثلا ثن درارهم والصحيح ثلاثمائة دارهم

[مصطفى كمال]

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

تقبل الله صيام وقيام الجميع بمزيد من الأجر والثواب

اخي الكريم خبرتي في vb محدودة جدا، ارجو أن تجد حلولا من طرف باقي الإخوة

[بوحماد]

بارك الله فيك اخى مصطفى

[أيسم إبراهيم]

السلام عليكم جميعا

شكرا أخي الأستاذ مصطفي على الكود. تعبناك معانا

أخي الكريم bast

تفضل المرفق تم تعديل الكود ليناسب طلبك

جرب و اخبرني بالنتيجة

دمتم جميعا بخير

أيسم إبراهيم

tafkeet.rar

[بوحماد]

السلام عليكم اخى ايسم

مشكور على هذا الجهد والهتمام لاكن مازل فية مشكلة مثلا نكتب 100.200 مائة دينار ومائتان دارهم فى الملف المرفق

مائة دينار ووعشرون دارهم One Hundred Dinars And Twenty Derham

المشكلة فى الدراهم باس الباقى تمام نامل تعديل الدرهم تحياتى

[أيسم إبراهيم]

السلام عليكم

أخي الكريم

لي سؤال:

هو الدينار يساوي كام درهم؟؟؟

للتعديل على جبر الكسر في الكود

منتظر ردك

أيسم إبراهيم

[بوحماد]

السلام عليكم

الدينار يساوى 1000 درهم

[مصطفى كمال]

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

تقبل الله صيام وقيام الجميع بمزيد من الأجر والثواب

تفضل أخي الكريم Bast الملف المرفق ، ارجو أن يكون ما طلبت في انتظار البحث عن دالة أفضل

10330.rar

[بوحماد]

مشكور اخى مصطفى ماشالله عليك وبارك اله فيك أنت واخى ايسام ابراهيم على هتمامك تقبل الله صيامك

لاكن عند طلب بسيط هل فية طريقة تحول الدراهم الى حروف بدلا من One Hundred Dinar and 200 dirham Only

200 دارهم على العموم مشكورين وبارك الله فيكم جميعا

[مصطفى كمال]

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

تقبل الله صيام وقيام الجميع بمزيد من الأجر والثواب

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

ونحن في العشر الأواخر من رمضان

تفضل أخي الكريم bast الملف المرفق فقد تم توفير طلبك

تم إضافة الملف الأصلي ( قاعدة بيانات اكسس ) موضح فيه طريقة كتابة الدالة وضبطها بالشكل الصحيح

الحمد لله رب العالمين

Bureau.rar

[وليد المصرى 1]

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

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

'Option Compare Database

Public ÇáÑÞã_ÑÞãÇð2, ÇáÑÞã_ßÊÇÈÉ2

Public Sub ÊÍæíá_ÇáÑÞã_ßÊÇÈÉ2()

ÇáÑÞã_ÑÞãÇð2 = Round(ÇáÑÞã_ÑÞãÇð2, 2)

Dim ÊÌÑÈÉ, ÑÞã_Ãæáí, ÞÑÇÁÉ_Ãæáì

Dim ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ

Dim ÑÞã_ÕÝÑí, ÇáÂÍÇÏ, ÇáÚÔÑÇÊ, ÇáãÆÇÊ, ÇáÃáæÝ, ÚÔÑÇÊ_ÇáÃáæÝ, ãÆÇÊ_ÇáÃáæÝ, ãáÇííä

Dim ÇáÝÆÉ As String

Const ÑíÇá = "ÑíÇá"

' ÇáÂÍÇÏ

' ÇáÔÑØ ÇáÊÇáí áÛÑÖ ÚÏã ÅÏÎÇá ÑÞã ÕÍíÍ ÚäÏ æÌæÏ ÑÞã æÇÍÏ ááåááÉ

'MsgBox ÇáÑÞã_ÑÞãÇð2

'MsgBox Fix(ÇáÑÞã_ÑÞãÇð2) * 100

'ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ = CInt((ÇáÑÞã_ÑÞãÇð2 - Fix(ÇáÑÞã_ÑÞãÇð2)) * 100)

'MsgBox ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ

If Right([ÇáÑÞã_ÑÞãÇð2], 3) < 1 Then

ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ = Right([ÇáÑÞã_ÑÞãÇð2], 3)

Else

ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ = Right([ÇáÑÞã_ÑÞãÇð2], 2)

End If

If ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ >= 1 Then

ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ = 0

End If

'ÇáÔÑØ ÇáÊÇáí áÛÑÖ ÚÏã ÇáØÑÍ ÅÐÇ áã íæÌÏ ÃÑÞÇã ÈÚÏ ÇáÝÇÕáÉ

If ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ < 1 Then

ÇáÑÞã_ÑÞãÇð2 = ÇáÑÞã_ÑÞãÇð2 - ÇáÃÑÞÇã_ÈÚÏ_ÇáÝÇÕáÉ

End If

ÞÑÇÁÉ_Ãæáì = Left([ÇáÑÞã_ÑÞãÇð2], 1)

ÑÞã_Ãæáí = Choose(ÞÑÇÁÉ_Ãæáì, "æÇÍÏ", "ÅËäÇä", "ËáÇËÉ", "ÃÑÈÚÉ", "ÎãÓÉ", "ÓÊÉ", "ÓÈÚÉ", "ËãÇäíÉ", "ÊÓÚÉ")

' ÑÞã æÇÍÏ

If Len([ÇáÑÞã_ÑÞãÇð2]) = 1 Then

' ÊÚÏíá æÇÍÏ ÑíÇá

[ÇáÑÞã_ßÊÇÈÉ2] = ÑÞã_Ãæáí

[postscripter]

انصح باستخدام موقع تفقيط الألكتروني www.tafqit.com