10:52 AM |الساعة الآن   
 
العودة ملتقى الموظف الجزائرى  :: 

منتدى التكنولوجيا والاعلام الالى

 :: 

الكمبيوتر والإنترنت






أهلا وسهلا بك إلى ملتقى الموظف الجزائرى.
أهلا وسهلا بك زائرنا الكريم، إذا كانت هذه زيارتك الأولى للمنتدى، فيرجى التكرم بزيارة صفحة التعليمـــات، بالضغط هنا.كما يشرفنا أن تقوم بالتسجيل بالضغط هنا إذا رغبت بالمشاركة في المنتدى، أما إذا رغبت بقراءة المواضيع والإطلاع فتفضل بزيارة القسم الذي ترغب أدناه.

الرئيسيةالبوابةبحـثس .و .جدخولالتسجيل
اعلان هام للمسجلين الجدد :بمجرد التسجيل يتم إرسال كود التفعيل إلى حسابك .. أي الإيميل الذي وضعته عند التسجيل بالمنتدى ... إذهب إلى علبة البريد فإذا لم تجده في الرسائل الواردة حاول أن تبحث عنه في صندوق بريد الغير مرغوب فيه SPAM



تحويل الارقام الى حروف باللوغة العربية


شاطر
 #1  
السبت 12 مارس 2011, 14:20
 
 
 
ذكر
الاقامة : algeri
المشاركات : 123
نقاط : 136
تاريخ التسجيل : 04/08/2010
العمل : fonctionaire
افتراضيتحويل الارقام الى حروف باللوغة العربية

طلب مساعة بخصوص تحويل الارقام الى حروف ببرنامج الاكسال من فضلكم


 #2  
السبت 12 مارس 2011, 15:05
 
 
 
ذكر
الاقامة : algerie
المشاركات : 159
نقاط : 242
تاريخ التسجيل : 23/01/2011
العمر : 41
العمل : adminisrateur
المزاج المزاج : مرح وبشوش دائما
افتراضيرد: تحويل الارقام الى حروف باللوغة العربية

الاخ محمد لدي دالة منجزة تستعمل فقط بالاكسال الخاص ب الافيس 2003 وسوف اعطيك طريقة تثبيتها في الاكسال وهي كالتالي:
-افتح صفحة الاكسال واضغط على الخانة التي ترغب التحويل اليها
بعد ذلك توجه لقائمة ادوات واضغط على ماكرو ثم على محرر الفيزيال بازيك فتظهر لك صفحة جديدة فارغة للمحرر
ثم اختار usert userfrom هي بالقرب من مفتاح الحفظ لليسار تماما فتظهر لك 03 خيارات اختارmodule فتظهر لك نافذة فارغة بيضاء قم بنسخ هذه الدالة ولصقها في الفراغ الدالة هي:
'NombreToArabe(Cellule)
'Conversion Automatique de Chiffre en Lettre Arabe
'Date:01 juillet 2010
'sidi ameur


Function lireCentaine(ByVal Montant As Double) As String
Dim ChiffreLettre
Dim Centaine As Double
Dim Dizaine As Double
Dim T As String
Dim Chaine As String
ChiffreLettre = Array("واحد", "إثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "إحدى عشر", "إثنى عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر")
Centaine = Int(Montant / 100)
Select Case Centaine
Case 0
Chaine = ""
Case 1
Chaine = "مائة"
Case 2
Chaine = "مائتان"
Case 3
Chaine = "ثلاثمائة"
Case 4
Chaine = "أربعمائة"
Case 5
Chaine = "خمسمائة"
Case 6
Chaine = "ستمائة"
Case 7
Chaine = "سبعمائة"
Case 8
Chaine = "ثمانمائة"
Case 9
Chaine = "تسعمائة"
End Select
Dizaine = Modulo(Montant, 100)
Select Case Dizaine
Case 0
T = ""
Case 1 To 19
T = ChiffreLettre(Dizaine - 1)
Case 20
T = " عشرون"
Case 21 To 29
T = ChiffreLettre(Dizaine - 21) & " و عشرون"
Case 30
T = " ثلاثون"
Case 31 To 39
T = ChiffreLettre(Dizaine - 31) & " و ثلاثون"
Case 40
T = " أربعون"
Case 41 To 49
T = ChiffreLettre(Dizaine - 41) & " و أربعون"
Case 50
T = " خمسون"
Case 51 To 59
T = ChiffreLettre(Dizaine - 51) & " و خمسون"
Case 60
T = " ستون"
Case 61 To 69
T = ChiffreLettre(Dizaine - 61) & " و ستون"
Case 70
T = " سبعون"
Case 71 To 79
T = ChiffreLettre(Dizaine - 71) & " و سبعون"
Case 80
T = " ثمانون"
Case 81 To 89
T = ChiffreLettre(Dizaine - 81) & " و ثمانون"
Case 90
T = " تسعون"
Case 90 To 99
T = ChiffreLettre(Dizaine - 91) & " و تسعون"
Case Else
T = "Erreur de conversion !"
End Select
If Chaine <> "" Then
If (T <> "") Then
Chaine = Chaine
T = " و " & T
End If
End If
If Chaine = "" Then
If (T <> "") Then
Chaine = Chaine
T = T
End If
End If
If (Chaine & " " & T) = " " Then
lireCentaine = ""
Else
lireCentaine = LTrim(Chaine & " ") & T
End If
End Function
Function Modulo(ByVal Nombre As Double, ByVal Diviseur As Double) As Double
Modulo = Nombre - (Diviseur * Int(Nombre / Diviseur))
End Function
Function Arrondir(ByVal ValeurArrondi As Double, ByVal NbreDeci As Integer) As Double
Arrondir = ValeurArrondi + (5 * 10 ^ -(NbreDeci + 1))
Arrondir = Int(Arrondir * 10 ^ NbreDeci) / 10 ^ NbreDeci
End Function
Function NombreToArabe(ByVal Total As Double) As String
Dim Millions As Double
Dim Milliers As Double
Dim cent As Double
Dim decimales As Double
Dim T0 As String
Dim T1 As String
Dim T2 As String
Dim T3 As String
Dim Resultat As String
Dim T As String
Total = Arrondir(Total, 2)
Millions = Int(Modulo(Int(Total / 1000000), 1000))
Milliers = Int(Modulo(Int(Total / 1000), 1000))
cent = Int(Modulo(Total, 1000))
decimales = Arrondir((Modulo(Total * 100, 100)), 0)
T0 = lireCentaine(Millions)
T1 = lireCentaine(Milliers)
T2 = lireCentaine(cent)
T3 = lireCentaine(decimales)
If T0 <> "" Then
If (T1 <> "") Then
If (T2 <> "") Then
T0 = T0
T1 = " و " & T1
T2 = " و " & T2
End If
End If
End If
If T0 = "" Then
If (T1 <> "") Then
If (T2 <> "") Then
T0 = T0
T1 = T1
T2 = " و " & T2
End If
End If
End If
If T0 <> "" Then
If (T1 <> "") Then
If (T2 = "") Then
T0 = T0
T1 = " و " & T1
T2 = T2
End If
End If
End If
If T0 = "" Then
If (T1 <> "") Then
If (T2 = "") Then
T0 = T0
T1 = T1
T2 = T2
End If
End If
End If
If T0 <> "" Then
If (T2 <> "") Then
If (T1 = "") Then
T0 = T0
T2 = " و " & T2
T1 = T1
End If
End If
End If
If T0 = "" Then
If (T2 <> "") Then
If (T1 = "") Then
T0 = T0
T1 = T1
T2 = T2
End If
End If
End If
If T0 = "واحد" Then
T0 = ""
Resultat = Resultat & T0 & " مليون "
End If
If T0 = "إثنان" Then
T0 = ""
Resultat = Resultat & T0 & " مليونان "
End If
If Millions >= 3 And Millions <= 10 Then
Resultat = Resultat & T0 & " ملايين "
End If
If Millions >= 11 And Millions <= 999 Then
Resultat = Resultat & T0 & " مليون "
Else
Resultat = Resultat & ""
End If
If T1 = "واحد" Then
T1 = ""
Resultat = Resultat & T1 & " ألف "
End If
If T1 = "إثنان" Then
T1 = ""
Resultat = Resultat & T1 & " ألفان "
End If
If Milliers >= 3 And Milliers <= 10 Then
Resultat = Resultat & T1 & " ألاف "
End If
If Milliers >= 11 And Milliers <= 999 Then
Resultat = Resultat & T1 & " ألف "
Else
Resultat = Resultat & ""
End If
If T2 <> "" Then
Resultat = Resultat & T2 & " دج "
Else
If Resultat <> "" Then
Resultat = Resultat & " دج "
End If
End If
If T3 <> "" Then
If Resultat <> "" Then
Resultat = Resultat & " و " & T3 & " سنتيما"
Else
Resultat = T3 & " سنتيما"
End If
End If
NombreToArabe = Resultat
End Function
بعد ذلك اضغط على run sub وهو عبارة عن نافذة صغيرة على شكل مثلث لتظهر لك نافذة macros name قم يتسميتها اي اسم ثم احفظ العملية لك الخيار في جعلها تطبق على هذا المف او على كل ملفات الاكسال في السطر الاخير من نافذة الحفظ
ثم اغلق صفحة محرر الباسيك وعد لصفحة الاكسال ثم اضغط على الخانة التي ترغب في وضع وكتابة الحروف بها ثم اضغط على قائمة ادارج ثم دالة وابحث عن اسم الدالة وهو NombreToArabe ثم اضغط على الرقم المراد تحويله لحروف وسوف يقوم الاكسال تلقائيا بتحويل الرقام لحروف في كل مرة تغير فيها الرقم وبالتوفيق لاتنسى الدعاء بالخيروان كنت ترغب في نموذج معين لفاتورة او حوالة او مداولة بها هذه الطريقة سارسلها لك


 #3  
السبت 12 مارس 2011, 15:13
 
 
 
ذكر
الاقامة : algerie
المشاركات : 159
نقاط : 242
تاريخ التسجيل : 23/01/2011
العمر : 41
العمل : adminisrateur
المزاج المزاج : مرح وبشوش دائما
افتراضيرد: تحويل الارقام الى حروف باللوغة العربية

عفوا الاخ محمد لقد قمت بتصحيحها نظرا لورود خطأ في الاولى
تستعمل فقط بالاكسال الخاص ب الافيس 2003 وسوف اعطيك طريقة تثبيتها في الاكسال وهي كالتالي:
-افتح صفحة الاكسال واضغط على الخانة التي ترغب التحويل اليها
بعد ذلك توجه لقائمة ادوات واضغط على ماكرو ثم على محرر الفيزيال بازيك فتظهر لك صفحة جديدة فارغة للمحرر
ثم اختار usert userfrom هي بالقرب من مفتاح الحفظ لليسار تماما فتظهر لك 03 خيارات اختارmodule فتظهر لك نافذة فارغة بيضاء قم بنسخ هذه الدالة ولصقها في الفراغ الدالة هي:
'NombreToArabe(Cellule)
'Conversion Automatique de Chiffre en Lettre Arabe
Function lireCentaine(ByVal Montant As Double) As String
Dim ChiffreLettre
Dim Centaine As Double
Dim Dizaine As Double
Dim T As String
Dim Chaine As String
ChiffreLettre = Array("واحد", "إثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "إحدى عشر", "إثنى عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر")
Centaine = Int(Montant / 100)
Select Case Centaine
Case 0
Chaine = ""
Case 1
Chaine = "مائة"
Case 2
Chaine = "مائتان"
Case 3
Chaine = "ثلاثمائة"
Case 4
Chaine = "أربعمائة"
Case 5
Chaine = "خمسمائة"
Case 6
Chaine = "ستمائة"
Case 7
Chaine = "سبعمائة"
Case 8
Chaine = "ثمانمائة"
Case 9
Chaine = "تسعمائة"
End Select
Dizaine = Modulo(Montant, 100)
Select Case Dizaine
Case 0
T = ""
Case 1 To 19
T = ChiffreLettre(Dizaine - 1)
Case 20
T = " عشرون"
Case 21 To 29
T = ChiffreLettre(Dizaine - 21) & " و عشرون"
Case 30
T = " ثلاثون"
Case 31 To 39
T = ChiffreLettre(Dizaine - 31) & " و ثلاثون"
Case 40
T = " أربعون"
Case 41 To 49
T = ChiffreLettre(Dizaine - 41) & " و أربعون"
Case 50
T = " خمسون"
Case 51 To 59
T = ChiffreLettre(Dizaine - 51) & " و خمسون"
Case 60
T = " ستون"
Case 61 To 69
T = ChiffreLettre(Dizaine - 61) & " و ستون"
Case 70
T = " سبعون"
Case 71 To 79
T = ChiffreLettre(Dizaine - 71) & " و سبعون"
Case 80
T = " ثمانون"
Case 81 To 89
T = ChiffreLettre(Dizaine - 81) & " و ثمانون"
Case 90
T = " تسعون"
Case 90 To 99
T = ChiffreLettre(Dizaine - 91) & " و تسعون"
Case Else
T = "Erreur de conversion !"
End Select
If Chaine <> "" Then
If (T <> "") Then
Chaine = Chaine
T = " و " & T
End If
End If
If Chaine = "" Then
If (T <> "") Then
Chaine = Chaine
T = T
End If
End If
If (Chaine & " " & T) = " " Then
lireCentaine = ""
Else
lireCentaine = LTrim(Chaine & " ") & T
End If
End Function
Function Modulo(ByVal Nombre As Double, ByVal Diviseur As Double) As Double
Modulo = Nombre - (Diviseur * Int(Nombre / Diviseur))
End Function
Function Arrondir(ByVal ValeurArrondi As Double, ByVal NbreDeci As Integer) As Double
Arrondir = ValeurArrondi + (5 * 10 ^ -(NbreDeci + 1))
Arrondir = Int(Arrondir * 10 ^ NbreDeci) / 10 ^ NbreDeci
End Function
Function NombreToArabe(ByVal Total As Double) As String
Dim Millions As Double
Dim Milliers As Double
Dim cent As Double
Dim decimales As Double
Dim T0 As String
Dim T1 As String
Dim T2 As String
Dim T3 As String
Dim Resultat As String
Dim T As String
Total = Arrondir(Total, 2)
Millions = Int(Modulo(Int(Total / 1000000), 1000))
Milliers = Int(Modulo(Int(Total / 1000), 1000))
cent = Int(Modulo(Total, 1000))
decimales = Arrondir((Modulo(Total * 100, 100)), 0)
T0 = lireCentaine(Millions)
T1 = lireCentaine(Milliers)
T2 = lireCentaine(cent)
T3 = lireCentaine(decimales)
If T0 <> "" Then
If (T1 <> "") Then
If (T2 <> "") Then
T0 = T0
T1 = " و " & T1
T2 = " و " & T2
End If
End If
End If
If T0 = "" Then
If (T1 <> "") Then
If (T2 <> "") Then
T0 = T0
T1 = T1
T2 = " و " & T2
End If
End If
End If
If T0 <> "" Then
If (T1 <> "") Then
If (T2 = "") Then
T0 = T0
T1 = " و " & T1
T2 = T2
End If
End If
End If
If T0 = "" Then
If (T1 <> "") Then
If (T2 = "") Then
T0 = T0
T1 = T1
T2 = T2
End If
End If
End If
If T0 <> "" Then
If (T2 <> "") Then
If (T1 = "") Then
T0 = T0
T2 = " و " & T2
T1 = T1
End If
End If
End If
If T0 = "" Then
If (T2 <> "") Then
If (T1 = "") Then
T0 = T0
T1 = T1
T2 = T2
End If
End If
End If
If T0 = "واحد" Then
T0 = ""
Resultat = Resultat & T0 & " مليون "
End If
If T0 = "إثنان" Then
T0 = ""
Resultat = Resultat & T0 & " مليونان "
End If
If Millions >= 3 And Millions <= 10 Then
Resultat = Resultat & T0 & " ملايين "
End If
If Millions >= 11 And Millions <= 999 Then
Resultat = Resultat & T0 & " مليون "
Else
Resultat = Resultat & ""
End If
If T1 = "واحد" Then
T1 = ""
Resultat = Resultat & T1 & " ألف "
End If
If T1 = "إثنان" Then
T1 = ""
Resultat = Resultat & T1 & " ألفان "
End If
If Milliers >= 3 And Milliers <= 10 Then
Resultat = Resultat & T1 & " ألاف "
End If
If Milliers >= 11 And Milliers <= 999 Then
Resultat = Resultat & T1 & " ألف "
Else
Resultat = Resultat & ""
End If
If T2 <> "" Then
Resultat = Resultat & T2 & " دج "
Else
If Resultat <> "" Then
Resultat = Resultat & " دج "
End If
End If
If T3 <> "" Then
If Resultat <> "" Then
Resultat = Resultat & " و " & T3 & " سنتيما"
Else
Resultat = T3 & " سنتيما"
End If
End If
NombreToArabe = Resultat
End Function
بعد ذلك اضغط على run sub وهو عبارة عن نافذة صغيرة على شكل مثلث لتظهر لك نافذة macros name قم يتسميتها اي اسم ثم احفظ العملية لك الخيار في جعلها تطبق على هذا المف او على كل ملفات الاكسال في السطر الاخير من نافذة الحفظ
ثم اغلق صفحة محرر الباسيك وعد لصفحة الاكسال ثم اضغط على الخانة التي ترغب في وضع وكتابة الحروف بها ثم اضغط على قائمة ادارج ثم دالة وابحث عن اسم الدالة وهو NombreToArabe ثم اضغط على الرقم المراد تحويله لحروف وسوف يقوم الاكسال تلقائيا بتحويل الرقام لحروف في كل مرة تغير فيها الرقم وبالتوفيق لاتنسى الدعاء بالخيروان كنت ترغب في نموذج معين لفاتورة او حوالة او مداولة بها هذه الطريقة سارسلها لك


 #4  
الإثنين 01 أغسطس 2011, 11:25
 
 
 
ذكر
الاقامة : برج بوعريريج
المشاركات : 62
نقاط : 80
تاريخ التسجيل : 27/04/2011
العمل : مساعد المصالح الاقتصادية
المزاج المزاج : هادئ
افتراضيرد: تحويل الارقام الى حروف باللوغة العربية

بارك الله فيكم على هذه المجهودات الجبارة


 #5  
الإثنين 08 أغسطس 2011, 14:56
 
 
 
ذكر
الاقامة : المدية
المشاركات : 295
نقاط : 467
تاريخ التسجيل : 22/04/2011
العمل : موظف - DEUA اعلام الي
المزاج المزاج : جزائري
افتراضيرد: تحويل الارقام الى حروف باللوغة العربية

السلام عليكم
راجع الرابط التالي
رمضان مبارك
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذا الرابط]



 #6  
الأحد 13 نوفمبر 2011, 14:10
 
 
 
ذكر
الاقامة : الجزائر
المشاركات : 27
نقاط : 35
تاريخ التسجيل : 02/02/2011
العمر : 52
العمل : ملحق رئيسي للإدارة
افتراضيرد: تحويل الارقام الى حروف باللوغة العربية

بارك الله فيك و جزاك الله خيرا


 #7  
السبت 19 نوفمبر 2011, 18:21
 
 
 
ذكر
الاقامة : باتنة
المشاركات : 103
نقاط : 103
تاريخ التسجيل : 16/11/2011
العمر : 37
العمل : موظف دائم
المزاج المزاج : عادي جدا
افتراضيرد: تحويل الارقام الى حروف باللوغة العربية

هل هناك دالة تصلح على اوفيس 2007


 #8  
الخميس 01 أغسطس 2013, 02:54
 
ذكر
الاقامة : ;وهران
المشاركات : 1
نقاط : 1
تاريخ التسجيل : 01/08/2013
العمل : محاسب
افتراضيرد: تحويل الارقام الى حروف باللوغة العربية

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

جلول علي






 
الإشارات المرجعية


  
وما من كاتب إلا سيفنى . ويبقي الدهر ما كتبت يداه



تعليمات المشاركة
صلاحيات هذا المنتدى:
لاتستطيع الرد على المواضيع في هذا المنتدى

BB code is متاحة
كود [IMG] متاحة
كود HTML متاحة