اخواني الكرام :
معظمكم شاهد على الفواتير المبلغ بالأرقام ثم بجانبه المبلغ كتابة...مثلاً :
110 ريال
مائة وعشرة ريالات..
وإليكم الكود لهذه العملية وهو مفيد في برامج المحاسبة والمستودعات..
شرح الكود :
هناك وحدتين :
الأولى : تحوي تابع اسمه : NoToText
والثانية : StringTool
تضيفهم إلى الـ Project
بفرض لدي ُEdit1 و Edit2 وأريد أم أدخل في الأولى رقماً وعلى حدث ما ( كالنقر على الزر مثلاً ) أن يظهر التنفقيط في الـ Edit2 فتكون صيغة استدعاء التابع كما يلي :
Edit2.Text:=NoToTxt(strtofloat(Edit1.Text),'ريال','هللة');
طبعاً تعلمون إنه يجب لإضافة الوحدة NoToText إلى قائمة الوحدات التي تستخدمها الوحدة التيتطبق عليها هذه العملية ... وإليكم الكود :
-----------------
unit NoToText;
interface
uses
SysUtils;
Function NoToTxt(TheNo:Double;MyCur:String;MySubCur:String): String;
implementation
Function NoToTxt(TheNo:Double;MyCur:String;MySubCur:String): String;
var
MyArry1 : Array [0..9] of String;
MyArry2 : Array [0..9] of String;
MyArry3 : Array [0..9] of String;
MyNo :String;
GetNo:String;
RdNo :String;
My100:String;
My10 :String;
My1 :String;
My11 :String;
My12 :String;
GetTxt :String;
Mybillion : String;
MyMillion : String;
MyThou :String;
MyHun : String;
MyFraction :String;
MyAnd :String;
i : Integer;
begin
if TheNo > 999999999999.99 then Exit;
if TheNo = 0 then
begin
Result := 'صفر';
Exit;
end;
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 := FormatFloat('000000000000.00',TheNo);
i := 0;
while i < 15 do
begin
if i < 12 then
begin
MyNo := Copy(GetNo,i+1,3);
end else begin
MyNo := '0' +Copy(GetNo,i+2,2);
end;
if StrToInt(Copy(MyNo,1,3)) > 0 then
begin
RdNo := Copy(MyNo,1,1);
My100 := MyArry1[strToInt(RdNo)] ;
RdNo := Copy(MyNo,3,1);
My1 := MyArry3[strToInt(RdNo)] ;
RdNo := Copy(MyNo,2,1);
My10 := MyArry2[strToInt(RdNo)] ;
if (StrToInt(Copy(MyNo,2,2)) = 11)then
My11 := 'إحدى عشر';
if (StrToInt(Copy(MyNo,2,2)) = 12)then
My12 :='إثنى عشر' ;
if (StrToInt(Copy(MyNo,1,1)) > 0)
and (StrToInt(Copy(MyNo,2,2)) > 0) then
My100 :=My100+ MyAnd;
if (StrToInt(Copy(MyNo,3,1)) > 0)
and (StrToInt(Copy(MyNo,2,1)) > 1) then
My1 :=My1+ MyAnd;
GetTxt := My100 + My1 + My10;
if (StrToInt(Copy(MyNo,3,1)) = 1) and (StrToInt(Copy(MyNo,2,1)) = 1) then
begin
GetTxt := My100 + My11;
if (StrToInt(Copy(MyNo,1,1)) = 0)then
GetTxt := My11 ;
end;
if (StrToInt(Copy(MyNo,3,1)) = 2) and (StrToInt(Copy(MyNo,2,1)) = 1) then
begin
GetTxt := My100 + My12 ;
if (StrToInt(Copy(MyNo,1,1)) = 0)then
GetTxt := My12 ;
end;
if (i = 0) and (GetTxt <> '') then
begin
if (StrToInt(Copy(MyNo,1,3)) = 1) or (StrToInt(Copy(MyNo,1,3)) > 9 )then
begin
Mybillion := GetTxt + ' مليار';
end else
begin
Mybillion := GetTxt + ' مليارات';
if (StrToInt(Copy(MyNo,1,3)) = 2) then Mybillion := ' ملياران';
end;
end;
if (i = 3) and (GetTxt <> '') then
begin
if (StrToInt(Copy(MyNo,1,3)) = 1) or (StrToInt(Copy(MyNo,1,3)) > 9 )then
begin
MyMillion := GetTxt + ' مليون';
end else
begin
MyMillion := GetTxt + ' ملايين';
if (StrToInt(Copy(MyNo,1,3)) = 2) then MyMillion := ' مليونان';
end;
end;
if (i = 6) and (GetTxt <> '') then
begin
if (StrToInt(Copy(MyNo,1,3)) = 1) or (StrToInt(Copy(MyNo,1,3)) > 9 )then
begin
MyThou := GetTxt + ' ألف';
end else
begin
MyThou := GetTxt + ' آلاف';
if (StrToInt(Copy(MyNo,3,1)) = 2) then MyThou := ' ألفان';
end;
end;
if (i = 9) and (GetTxt <> '') then MyHun := GetTxt;
if (i = 12)and (GetTxt <> '') then MyFraction := GetTxt;
end;
i :=i + 3;
end;
if (MyBillion<>'') then
begin
if (MyMillion <> '') Or (MyThou <> '') Or (MyHun <>'')then
MyBillion := MyBillion + MyAnd;
end;
if (MyMillion<>'') then
begin
if (MyThou <> '') Or (MyHun <>'') then
MyMillion := MyMillion + MyAnd;
end;
if (MyThou <>'') then
begin
if (MyHun <>'') then
MyThou := MyThou + MyAnd;
end;
if MyFraction <> '' then
begin
if (Mybillion <> '') Or(MyMillion <> '') Or (MyThou <> '') Or (MyHun <>'')then
begin Result := Mybillion + MyMillion + MyThou + MyHun + ' ' + MyCur + MyAnd + MyFraction + ' ' + MySubCur ;
end else begin Result := MyFraction + ' ' + MySubCur; end;
end else begin
Result := Mybillion + MyMillion + MyThou + MyHun + ' ' + MyCur ;
end
end;
end.
----------------------------------------------------------------------------------------------------
unit StringTool;
interface
Uses SysUtils;
Function NumberToWord(LangID: Word; nReal, nDec: LongInt; DecSign, CurrSign: PChar): PChar; export;
Function GetAraNum(MyNum: LongInt): String;
Function ConvertNum(MyNum: LongInt; Flag: Integer): String;
Procedure SetArray(MyStrNum: String);
Function GetEngNum(MyNum: LongInt): String;
implementation
Const
Waw = ' و ';
EWaw = ' and ';
Spc = ' ';
//Arabic Words
Ones: Array[1..9] of String = ('واحد', 'أثنان', 'ثلاثة', 'اربعة',
'خمسة', 'ستة', 'سبعة', 'ثمانية', 'تسعة');
Special: Array[1..2] of String = ('أحد', 'أثنا');
Single: String = 'عشر';
Tens: Array[1..9] of String = ('عشرة', 'عشرون', 'ثلاثون', 'اربعون',
'خمسون', 'ستون', 'سبعون', 'ثمانون', 'تسعون');
Hundreds: Array[1..2] of String = ('مائه', 'مائتان');
Thousnds: Array[1..3] of String = ('الف', 'الفان', 'الاف');
Milions: Array[1..3] of String = ('مليون', 'مليونان', 'ملايين');
//English Word
EOnes: Array[1..9] of String = ('One', 'Two', 'Three', 'Four', 'Five',
'Six', 'Seven', 'Eight' ,'Nine');
ETeens: Array[1..9] of String = ('Eleven', 'Twelve', 'Thirteen', 'Fourteen',
'Fifteen', 'Sixteen', 'Seventeen', 'Eighteen' ,
'Ninteen');
ETens: Array[1..9] of String = ('Ten', 'Twenty', 'Thirty', 'Fourty',
'Fifty', 'Sixty', 'Seventy', 'Eighty' ,'Ninty');
EHundreds = 'Hundred';
EThousand = 'Thousand';
EMilion = 'Million';
var
D: Array[1..20] of String;
N: Array[1..20] of String;
//***********************************************************************
// Number to words Procedure
//***********************************************************************
Procedure SetArray(MyStrNum: String);
var
I: Word;
begin
For I := 1 to Length(MyStrNum) do
D := Copy(MyStrNum, I, 1);
end;
Function ConvertNum(MyNum: LongInt; Flag: Integer): String;
begin
case Flag of
1: Result := Ones [MyNum];
2: Result := Ones [MyNum] + Spc + Single;
3: Result := Special [MyNum] + Spc + Single;
4: Result := Tens [MyNum];
5: Result := Hundreds [MyNum];
6: Result := Thousnds [MyNum];
7: Result := Milions [MyNum];
end;
end;
Function GetAraNum(MyNum: LongInt): String;
begin
Case MyNum of
0: Result := '';
1..9: Result := ConvertNum(MyNum, 1);
10: Result := ConvertNum(1, 4);
11, 12: Result := ConvertNum(MyNum-10, 3);
13..19: Result := ConvertNum(MyNum-10, 2);
20..99: begin
SetArray(IntToStr(MyNum));
if D[2] = '0' then Result := ConvertNum(MyNum div 10, 4)
else Result := ConvertNum(StrToInt(D[2]), 1) + Waw + ConvertNum(StrToInt(D[1]), 4);
end;
100..999: begin
SetArray(IntToStr(MyNum));
if (D[1] = '1') or (D[1] = '2') then N[1] := ConvertNum(StrToInt(D[1]), 5)
else N[1] := ConvertNum(StrToInt(D[1]), 1) + Spc + ConvertNum(1, 5);
N[2] := GetAraNum(StrToInt(D[2] + D[3]));
Result := N[1];
if Length(N[2]) > 2 then Result := N[1] + Waw + N[2];
end;
1000..9999: begin
SetArray(IntToStr(MyNum));
if (D[1] = '1') or (D[1] = '2') then N[3] := ConvertNum(StrToInt(D[1]), 6)
else N[3] := ConvertNum(StrToInt(D[1]), 1) + Spc + ConvertNum(3, 6);
N[4] := GetAraNum(StrToInt(D[2] + D[3] + D[4]));
Result := N[3];
if Length(N[4]) > 2 then Result := N[3] + Waw + N[4];
end;
end;
If (MyNum >= 10000) and (MyNum <= 99999) then begin
SetArray(IntToStr(MyNum));
if D[1] + D[2] = '10' then N[6] := Spc + ConvertNum(3, 6)
else N[6] := Spc + ConvertNum(1, 6);
N[5] := GetAraNum(StrToInt(D[1] + D[2])) + N[6];
N[6] := GetAraNum(StrToInt(D[3] + D[4] + D[5]));
Result := N[5];
if Length(N[6]) > 2 then Result := N[5] + Waw + N[6];
end
else If (MyNum >= 100000) and (MyNum <= 999999) then begin
SetArray(IntToStr(MyNum));
N[7] := GetAraNum(StrToInt(D[1] + D[2] + D[3])) + Spc + ConvertNum(1, 6);
N[8] := GetAraNum(StrToInt(D[4] + D[5] + D[6]));
Result := N[7];
if Length(N[8]) > 2 then Result := N[7] + Waw + N[8];
end
else If (MyNum >= 1000000) and (MyNum <= 9999999) then begin
SetArray(IntToStr(MyNum));
if (D[1] = '1') or (D[2] = '2') then N[9] := ConvertNum(StrToInt(D[1]), 7)
else N[9] := ConvertNum(StrToInt(D[1]), 1) + Spc + ConvertNum(3, 7);
N[10] := GetAraNum(StrToInt(D[2] + D[3] + D[4] + D[5] + D[6] + D[7]));
Result := N[9];
if Length(N[10]) > 2 then Result := N[9] + Waw + N[10];
end
else If (MyNum >= 10000000) and (MyNum <= 99999999) then begin
SetArray(IntToStr(MyNum));
if (D[1] + D[2]= '10') then N[12] := Spc + ConvertNum(3, 7)
else N[12] := Spc + ConvertNum(1, 7);
N[12] := GetAraNum(StrToInt(D[1] + D[2])) + N[12];
N[13] := GetAraNum(StrToInt(D[3] + D[4] + D[5] + D[6] + D[7] + D[8])) + N[6];
Result := N[12];
if Length(N[13]) > 2 then Result := N[12] + Waw + N[13];
end
else If (MyNum >= 100000000) and (MyNum <= 999999999) then begin
SetArray(IntToStr(MyNum));
N[14] := GetAraNum(StrToInt(D[1] + D[2] + D[3])) + Spc + ConvertNum(1, 7);
N[15] := GetAraNum(StrToInt(D[4] + D[5] + D[6] + D[7] + D[8] + D[9]));
Result := N[14];
if Length(N[15]) > 2 then Result := N[14] + Waw + N[15];
end
end;
Function GetEngNum(MyNum: LongInt): String;
var
I: Integer;
Dummy: String;
begin
Result := '';
If MyNum = 0 then Exit;
Case Length(IntToStr(MyNum)) of
1: Result := EOnes[MyNum];
2: begin
if (MyNum >= 11) and (MyNum <= 19) then Result := ETeens[MyNum - 10]
else begin
SetArray(IntToStr(MyNum));
Result := ETens[strToInt(D[1])];
if D[2] <> '0' then
Result := ETens[strToInt(D[1])] + Spc + EOnes[strToInt(D[2])];
end;
end;
3: begin
SetArray(IntToStr(MyNum));
N[1] := EOnes[strToInt(D[1])] + Spc + EHundreds;
N[2] := GetEngNum(StrToInt(D[2] + D[3]));
Result := N[1];
if Length(N[2]) > 2 then Result := N[1] + Spc + N[2];
end;
4, 5, 6: begin
SetArray(IntToStr(MyNum));
Dummy := '';
For I := 4 to Length(IntToStr(MyNum)) do
Dummy := Dummy + D[i-3];
N[3] := GetEngNum(StrToInt(Dummy)) + Spc + EThousand;
Dummy := '';
For I := Length(IntToStr(MyNum)) - 2 to Length(IntToStr(MyNum)) do
Dummy := Dummy + D;
N[4] := GetEngNum(StrToInt(Dummy));
Result := N[3];
if Length(N[4]) > 2 then Result := N[3] + Spc + N[4];
end;
7, 8, 9: begin
SetArray(IntToStr(MyNum));
Dummy := '';
For I := 7 to Length(IntToStr(MyNum)) do
Dummy := Dummy + D[i-6];
N[5] := GetEngNum(StrToInt(Dummy)) + Spc + EMilion;
Dummy := '';
For I := Length(IntToStr(MyNum)) - 5 to Length(IntToStr(MyNum)) do
Dummy := Dummy + D;
N[6] := GetEngNum(StrToInt(Dummy));
Result := N[5];
if Length(N[6]) > 2 then Result := N[5] + Spc + N[6];
end;
end;
end;
Function NumberToWord(LangID: Word; nReal, nDec: LongInt; DecSign, CurrSign: PChar): PChar;
var
Dummy: Array[0..2048] of char;
begin
Result := '';
If (nReal > 999999999) and (nDec > 999999999) then Exit;
Case LangID of
1: begin
If (nReal > 0) and (nDec > 0) then
StrPCopy(Dummy, GetEngNum(nReal) + Spc + StrPas(CurrSign) + EWaw + GetEngNum(nDec) + Spc + StrPas(DecSign))
else if nReal > 0 then StrPCopy(Dummy, GetEngNum(nReal) + Spc + StrPas(CurrSign))
else if nDec > 0 then StrPCopy(Dummy, GetEngNum(nDec) + Spc + StrPas(DecSign));
end;
2: begin
If (nReal > 0) and (nDec > 0) then
StrPCopy(Dummy, GetAraNum(nReal) + Spc + StrPas(CurrSign) + Waw + GetAraNum(nDec) + Spc + StrPas(DecSign))
else if nReal > 0 then StrPCopy(Dummy, GetAraNum(nReal) + Spc + StrPas(CurrSign))
else if nDec > 0 then StrPCopy(Dummy, GetAraNum(nDec) + Spc + StrPas(DecSign));
end;
end;
Result := Dummy;
end;
end.
ودمتم سالمين