ماژول تبديل عدد به حروف

با سلام
راستش من يه ماژول تبديل عدد به حروف مي خوام براي نمرات يه كارنامه كه مميز داره . 3 تا ماژول دارم اما جواب نمي ده البته ماژول هايي دارم كه جواب مي ده ولي بدون مميز تعريف شده و به درد من نمي خوره . مي شه لطف كنين كمكم كنين .

توي كدي كه توي اين فوروم پيدا كردم با سمي كالن مشكل دارم چون با اجراي كدها در وي بي اونها رو ارور ميگيره . چه بايد بكنم ؟
اگه هم يه ماژل مناسب دم دست داشته باشيد ممنون مي شم

سلام.
پروژه هاتونو خودتون بنویسید.

با سلام
دوست عزيز و استاد گرانمايه جناب پيام ...
اين شاگرد كمترين نه دانشجو هستم و نه جوان كه پروژه ام رو خودم بنويسم ....... . اين حقير براي كارهاي ساده شخصي از اكسس و وبي استفاده مي كنم و واقعا حسرت مي خورم كه چرا وقتي جوانتر بودم اقدام به يادگيري نكرده ام . حالا محتاج علم حضرتعالي و بقيه اساتيد توي اين زمينه ام . انصاف نيست كه جواب اين حقير را اينگونه بدهيد . اگرچه رنجيدم ولي باز هم مشكلم را مطرح مي كنم .
يه ماژول براي تبديل عدد به حروف نياز دارم كه اعشار رو عمل كنه . مثلا " دوازده و بيست و پنج " يا " دوازده مميز بيست و پنج " .
از اينكه تاپيك تكراري زدم عذرخواهي مي كنم .

ادغام دو تاپيك.

خانم هاتفي
متاسفانه چندي پيش با نزديك شدن به امتحانات پايان ترم حجم بسيار گسترده اي از سوالات و پروژهاي درسي به سمت فروم ما روانه شد و اين باعث شد كه نظم كلي انجمن از هم پاچيده بشه و كار رو براي ديگر كاربران در حال يادگيري يا كمك رسان دشوار كنه. افراد بدون اينكه هيچ گونه زحمتي به خودشون بدند سوال رو بدن كم و كاستي قرار ميدادند و تقاضاي جواب رو داشتند. براي حفظ سطح انجمنها چاره اي نداشتيم كه با اين پستها بصورت شديد برخورد كنيم كه البته به مدت دو ماه با قرار دادن اعلاميه اي در بالاي تمامي انجمنهاي برنامه نويسي از كاربران خواهش كرديم از مطرح كردن سوالات و پروژه هاي درسي خود خودداري كنند هر چند كه عده اي بدون هيچگونه توجهي همچنان به اينكارشون ادامه ميداند.

و متاسفانه سوال شما هم چون بصورت كامل و دقيق مطرح نشده بود و شما عضو تازه وارد انجمن هستيد... من - پيمان جان يا هر شخص ديگه اي هم به اشتباه فكر مي كرديم كه اين سوال شما درسي هست.

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

دوست و استاد گرامي
از بذل توجه حضرتعالي واقعا متشكرم . من قبلا مشكلاتمو توي فوروم اكسس سايت برنامه نويس مطرح مي كردم و بزرگواراني چون شارك جان عزيز ، استاد صارمي ، آقامصطفي و...... محبت مي كردند و راهنمايي مي كردند و من هم از آنجا يكم راه افتادم و كارهام خداروشكر پيش رفته . ولي متاسفانه نه رشته ام كامپيوتره و نه رياضي اما از برنامه نويسي لذت مي برم . بازم تشكر مي كنم . اميدوارم مزاحمتي براي فوروم شما ايجاد نكنم .
سوال : توي تاپيكي (يه ماژول مي خوام كه عدد ......) كه توي همين صفحه اول بود يه كد پيدا كردم كه .... ;lt.... توي اون ; رو نفهميدم و ارور ميده . خواهش مي كنم يه بزرگوار برام توضيح بده قضيه اين ; چيه ؟ اگه يه ماژل يا تابعي كه اعشارو ساپورت كنه برام بزارن ممنون ميشم .

سلام.
خانم هاتفی به دلیل سو تفاهم پیش آمده از شما معذرت میخواهم.
صابر خان همه چیز رو توضیح دادن. این روزها به دلیل حجم زیاد تاپیک های درخواست کد برای پروژه های دانشجویی علی رغم سعی بنده برای تشخیص صحیح متاسفانه این گونه سو تفاهم ها پیش میاد.
بنده شخصا مخالف پاسخ به دانشجویانی هستم که همیشه خواستار کد آماده هستن و زحمتی برای نوشتن پروژه های خود نمیکشن. این پروژه ها شروع برنامه نویسیه دانشجویان هست و اگر این برنامه های ساده رو هم ننویسن هیچ وقت برنامه نویس نمیشن. اینه که هر چند شاید پاسخ به سوالاتشون بسیار ساده باشه پاسخ نمیدم.

شما کدی رو که فرمودید این جا قرار بدید یا لینکشو بدید تا یه نگاهی بندازیم.
در ضمن بنده کوچیک و شاگرد شما پیمان هستم نه پیام.

استاد عزيز آقاي پيمان من هم از حضرتعالي عذر مي خواهم . با توضيحي كه دوست محترم صابرخان فرمودند رفع سو’تفاهم شد و حقير از اينكه بيجا متوقع شده بودم شرمنده شدم . اميدوارم ببخشيد .

اما اينم لينك تاپيك مربوطه ، كدهايي بود كه جناب "تكنيك برتر" نوشته بودند
[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]
من چندتا ماژول پيدا كردم كه بعضي هاش اعشار و مميز رو عمل نمي كرد و يكي دو تاش هم ارور ميداد از جمله همين . اگر ماژول ساده تري هم سراغ داشتيد ممنون ميشم لطف كنيد .
باز هم تشكر ميكنم و بابت توقع بيجا واقعا شرمنده ام . اميدوارم ببخشيد

اينم خود كد :
Option Explicit
Private Const hezar = " هزار"
Private Const melun = " ميليون"
Private Const melyard = " ميليارد"
Private Const va = " و "

Public Function heji_adad(ByVal adad As Double) As String
Dim hooroof As String
Dim SS As Integer 'sadgan
Dim hh As Integer 'hezargan
Dim mm As Integer 'melungan
Dim yy As Integer 'melyardgan
Dim STRadad As String
Dim LENadad As Integer

STRadad = Str(Val(Str(adad)))
LENadad = Len(STRadad)

Select Case adad
Case Is = 0
hooroof = "صفر"
Case 1 To 999
hooroof = Adad_Heji(adad)
Case 1000 To 999999
If (adad Mod 1000 = 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar
If (adad Mod 1000 <> 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar + va + (Adad_Heji(adad Mod 1000))
Case 1000000 To 999999999
SS = Val(Right$(STRadad, 3))
hh = Val(Mid$(STRadad, LENadad - 5, 3))
mm = Val(Left$(STRadad, LENadad - 6))
If (SS = 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun
If (SS = 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
If (SS <> 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(SS)
If (SS <> 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)
Case 1000000000 To 999999999999#
SS = Val(Right$(STRadad, 3))
hh = Val(Mid$(STRadad, LENadad - 5, 3))
mm = Val(Mid$(STRadad, LENadad - 8, 3))
yy = Val(Left$(STRadad, LENadad - 9))
If (SS = 0 And hh = 0 And mm = 0) Then hooroof = Adad_Heji(yy) + melyard
If (SS = 0 And hh = 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun
If (SS = 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
If (SS <> 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)
Case Is > 999999999999#
hooroof = "عدد وارد شده بزرگتر از 999999999999 است"
End Select
heji_adad = hooroof
End Function

Private Function Adad_Heji(ByVal adad As Integer) As String
Dim yekan As Byte
Dim dahgan As Byte
Dim sadgan As Byte
Dim behooroof As String
Dim heji(19) As String
Dim heji_dahgan(9) As String
Dim heji_sadgan(9) As String
'-------------------------------
heji(1) = "يک": heji(2) = "دو": heji(3) = "سه": heji(4) = "چهار": heji(5) = "پنج"
heji(6) = "شش": heji(7) = "هفت": heji(8) = "هشت": heji(9) = "نه": heji(10) = "ده"
heji(11) = "يازده": heji(12) = "دوازده": heji(13) = "سيزده": heji(14) = "چهارده": heji(15) = "پانزده"
heji(16) = "شانزده": heji(17) = "هفده": heji(18) = "هيجده": heji(19) = "نوزده"
'-------------------------------
heji_dahgan(1) = "ده"
heji_dahgan(2) = "بيست"
heji_dahgan(3) = "سي": heji_dahgan(4) = "چهل": heji_dahgan(5) = "پنجاه"
heji_dahgan(6) = "شصت": heji_dahgan(7) = "هفتاد": heji_dahgan(8) = "هشتاد"
heji_dahgan(9) = "نود"
'-------------------------------
heji_sadgan(1) = "يكصد": heji_sadgan(2) = "دويست": heji_sadgan(3) = "سيصد"
heji_sadgan(4) = "چهارصد": heji_sadgan(5) = "پانصد": heji_sadgan(6) = "ششصد"
heji_sadgan(7) = "هفتصد": heji_sadgan(8) = "هشتصد": heji_sadgan(9) = "نهصد"
'-------------------------------
yekan = adad Mod 10
dahgan = adad Mod 100
sadgan = Int(adad / 100)
'-------------------------------
If dahgan < 20 Then
If (sadgan = 0) Then behooroof = heji(dahgan)
If (sadgan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji(dahgan)
If (yekan = 0 And dahgan = 0) Then behooroof = heji_sadgan(sadgan)
Else
dahgan = (adad Mod 100) - yekan
If (sadgan = 0 And yekan = 0) Then behooroof = heji_dahgan(dahgan / 10)
If (sadgan = 0 And yekan <> 0) Then behooroof = heji_dahgan(dahgan / 10) + va + heji(yekan)
If (sadgan <> 0 And yekan = 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10)
If (sadgan <> 0 And yekan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10) + va + heji(yekan)
End If

Adad_Heji = behooroof
End Function

اينم دنبالش

Option Explicit
Private Const dahom = "دهم"
Private Const sadom = "صدم"

Private Function Meghdar(Addad)
Dim ziredah(9) As String
Dim dahtabist(19) As String
Dim dahi(9) As String

Dim Dot, Ashar, Yekan, Dahgan

ziredah(1) = "يك": ziredah(2) = "دو": ziredah(3) = "سه": ziredah(4) = "چهار": ziredah(5) = "پنج"
ziredah(6) = "شش": ziredah(7) = "هفت": ziredah(8) = "هشت": ziredah(9) = "نه"

dahtabist(11) = "يازده": dahtabist(12) = "دوازده": dahtabist(13) = "سيزده": dahtabist(14) = "چهارده": dahtabist(15) = "پانزده"
dahtabist(16) = "شانزده": dahtabist(17) = "هفده": dahtabist(18) = "هيجده": dahtabist(19) = "نوزده"

dahi(2) = "بيست": dahi(3) = "سي": dahi(4) = "چهل": dahi(5) = "پنجاه"
dahi(6) = "شصت": dahi(7) = "هفتاد": dahi(8) = "هشتاد": dahi(9) = "نود"

Dot = InStr(1, Addad, ".", vbTextCompare)
If Dot <> 0 Then
Ashar = Mid(Addad, Dot + 1, 2)
Select Case Len(Ashar)
Case Is = 2
If Mid(Ashar, 1, 1) = 0 And Mid(Ashar, 2, 2) <> 0 Then Meghdar = ziredah(Mid(Ashar, 2, 2)) & " " & sadom
If Ashar Mod 10 = 0 And Mid(Ashar, 2, 2) = 0 Then Meghdar = ziredah(Mid(Ashar, 1, 1)) & " " & dahom
If Ashar Mod 10 <> 0 And Mid(Ashar, 1, 1) <> 0 Then Meghdar = dahi(Mid(Ashar, 1, 1)) & " æ " & ziredah(Mid(Ashar, 2, 2)) & " " & sadom
If Mid(Ashar, 1, 1) = 0 And Mid(Ashar, 2, 2) = 0 Then Meghdar = "بدون اعشار"
If Ashar > 10 And Ashar < 20 Then Meghdar = dahtabist(Ashar) & " " & sadom
Case Is = 1
If Mid(Ashar, 1, 1) = 0 Then Meghdar = "بدون اعشار"
If Mid(Ashar, 1, 1) <> 0 Then Meghdar = ziredah(Mid(Ashar, 1, 1)) & " " & dahom
Case Is = 0
Meghdar = "بدون اعشار"
End Select
Else
Meghdar = "بدون اعشار"
End If
End Function__________________

خيلي حياتي نياز دارم

نقل قول:

---

نوشته شده توسط Mahsa Hatefi

عمل نمي كرد و يكي دو تاش هم ارور ميداد از جمله همين

---

این به خاطر اینه که توی سایت گذاشتند (مربوط به تگ های اچ تی ام ال )هستش
این مشکل رو بر طرف کردم و گذاشتمش تویه یه ماژول که اونو می تونید از اینجا دانلود کنید
[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]
و اگه نشد
[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

با تشکر از دوستان ماژول ارائه شده در اعداد 1.939.000.595 هیچ خروجی داده نمی شد.
ماژول مربوطه به شرح ذیل اصلاح گردید.

کد:

---

Option Explicit


Private Const dahom = "دهم"
Private Const sadom = "صدم"
Private Const hezar = " هزار"
Private Const melun = " ميليون"
Private Const melyard = " ميليارد"
Private Const va = " و "


Public Function dsHoroof(ByVal adad As Double) As String
    Dim hooroof As String
    Dim ss As Integer 'sadgan
    Dim hh As Integer 'hezargan
    Dim mm As Integer 'melungan
    Dim yy As Integer 'melyardgan
    Dim STRadad As String
    Dim LENadad As Integer
   
    STRadad = str(Val(str(adad)))
    LENadad = Len((STRadad))
   
    Select Case adad
        Case Is = 0
            hooroof = "صفر"
        Case 1 To 999
            hooroof = Adad_Heji(adad)
        Case 1000 To 999999
            If (adad Mod 1000 = 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar
            If (adad Mod 1000 <> 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar + va + (Adad_Heji(adad Mod 1000))
        Case 1000000 To 999999999
            ss = Val(Right$(STRadad, 3))
            hh = Val(Mid$(STRadad, LENadad - 5, 3))
            mm = Val(Left$(STRadad, LENadad - 6))
            If (ss = 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun
            If (ss = 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
            If (ss <> 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(ss)
            If (ss <> 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(ss)
        Case 1000000000 To 999999999999#
            ss = Val(Right$(STRadad, 3))
            hh = Val(Mid$(STRadad, LENadad - 5, 3))
            mm = Val(Mid$(STRadad, LENadad - 8, 3))
            yy = Val(Left$(STRadad, LENadad - 9))
            If (ss = 0 And hh = 0 And mm = 0) Then hooroof = Adad_Heji(yy) + melyard
            If (ss = 0 And hh = 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun
            If (ss = 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
                        ' اين خط اضافه شده
            If (ss <> 0 And hh = 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(ss)
            If (ss <> 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(ss)
        Case Is > 999999999999#
            hooroof = "عدد وارد شده بزرگتر از 999999999999 است"
    End Select
   
    dsHoroof = hooroof
End Function


Private Function Adad_Heji(ByVal adad As Integer) As String
    Dim yekan As Byte
    Dim dahgan As Byte
    Dim sadgan As Byte
    Dim behooroof As String
    Dim heji(19) As String
    Dim heji_dahgan(9) As String
    Dim heji_sadgan(9) As String
    '-------------------------------
    heji(1) = "يک": heji(2) = "دو": heji(3) = "سه": heji(4) = "چهار": heji(5) = "پنج"
    heji(6) = "شش": heji(7) = "هفت": heji(8) = "هشت": heji(9) = "نه": heji(10) = "ده"
    heji(11) = "يازده": heji(12) = "دوازده": heji(13) = "سيزده": heji(14) = "چهارده": heji(15) = "پانزده"
    heji(16) = "شانزده": heji(17) = "هفده": heji(18) = "هيجده": heji(19) = "نوزده"
    '-------------------------------
    heji_dahgan(1) = "ده"
    heji_dahgan(2) = "بيست"
    heji_dahgan(3) = "سي": heji_dahgan(4) = "چهل": heji_dahgan(5) = "پنجاه"
    heji_dahgan(6) = "شصت": heji_dahgan(7) = "هفتاد": heji_dahgan(8) = "هشتاد"
    heji_dahgan(9) = "نود"
    '-------------------------------
    heji_sadgan(1) = "يكصد": heji_sadgan(2) = "دويست": heji_sadgan(3) = "سيصد"
    heji_sadgan(4) = "چهارصد": heji_sadgan(5) = "پانصد": heji_sadgan(6) = "ششصد"
    heji_sadgan(7) = "هفتصد": heji_sadgan(8) = "هشتصد": heji_sadgan(9) = "نهصد"
    '-------------------------------
    yekan = adad Mod 10
    dahgan = adad Mod 100
    sadgan = Int(adad / 100)
    '-------------------------------
    If dahgan < 20 Then
        If (sadgan = 0) Then behooroof = heji(dahgan)
        If (sadgan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji(dahgan)
        If (yekan = 0 And dahgan = 0) Then behooroof = heji_sadgan(sadgan)
    Else
        dahgan = (adad Mod 100) - yekan
        If (sadgan = 0 And yekan = 0) Then behooroof = heji_dahgan(dahgan / 10)
        If (sadgan = 0 And yekan <> 0) Then behooroof = heji_dahgan(dahgan / 10) + va + heji(yekan)
        If (sadgan <> 0 And yekan = 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10)
        If (sadgan <> 0 And yekan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10) + va + heji(yekan)
    End If
   
    Adad_Heji = behooroof
End Function


Private Function Meghdar(Addad)
    Dim ziredah(9) As String
    Dim dahtabist(19) As String
    Dim dahi(9) As String
   
    Dim Dot, Ashar, yekan, dahgan
   
    ziredah(1) = "يك": ziredah(2) = "دو": ziredah(3) = "سه": ziredah(4) = "چهار": ziredah(5) = "پنج"
    ziredah(6) = "شش": ziredah(7) = "هفت": ziredah(8) = "هشت": ziredah(9) = "نه"
   
    dahtabist(11) = "يازده": dahtabist(12) = "دوازده": dahtabist(13) = "سيزده": dahtabist(14) = "چهارده": dahtabist(15) = "پانزده"
    dahtabist(16) = "شانزده": dahtabist(17) = "هفده": dahtabist(18) = "هيجده": dahtabist(19) = "نوزده"
   
    dahi(2) = "بيست": dahi(3) = "سي": dahi(4) = "چهل": dahi(5) = "پنجاه"
    dahi(6) = "شصت": dahi(7) = "هفتاد": dahi(8) = "هشتاد": dahi(9) = "نود"
   
    Dot = InStr(1, Addad, ".", vbTextCompare)
    If Dot <> 0 Then
        Ashar = Mid(Addad, Dot + 1, 2)
        Select Case Len(Ashar)
            Case Is = 2
                If Mid(Ashar, 1, 1) = 0 And Mid(Ashar, 2, 2) <> 0 Then Meghdar = ziredah(Mid(Ashar, 2, 2)) & " " & sadom
                If Ashar Mod 10 = 0 And Mid(Ashar, 2, 2) = 0 Then Meghdar = ziredah(Mid(Ashar, 1, 1)) & " " & dahom
                If Ashar Mod 10 <> 0 And Mid(Ashar, 1, 1) <> 0 Then Meghdar = dahi(Mid(Ashar, 1, 1)) & " &aelig; " & ziredah(Mid(Ashar, 2, 2)) & " " & sadom
                If Mid(Ashar, 1, 1) = 0 And Mid(Ashar, 2, 2) = 0 Then Meghdar = "بدون اعشار"
                If Ashar > 10 And Ashar < 20 Then Meghdar = dahtabist(Ashar) & " " & sadom
            Case Is = 1
                If Mid(Ashar, 1, 1) = 0 Then Meghdar = "بدون اعشار"
                If Mid(Ashar, 1, 1) <> 0 Then Meghdar = ziredah(Mid(Ashar, 1, 1)) & " " & dahom
            Case Is = 0
                Meghdar = "بدون اعشار"
        End Select
    Else
        Meghdar = "بدون اعشار"
    End If
End Function

---