إجراء التفقيط في لغة باسكال الدلفي - Function for Arabic Tafqeet

unit flyingTafqeet;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, Grids, DBGrids, StdCtrls, Mask, DBCtrls, Db, ComCtrls, Qrctrls, ExtCtrls;

   function SpellNumber(MyNumber: Real): string;
   function Horof(X: string): string;
   function SHorof(X: Real): string;
   function THorof(X: Real): string;

implementation

function SpellNumber(MyNumber: Real): string;
begin
Result := Horof(Trim(FloatToStr(MyNumber)));
end;

function Horof(X: string): string;
var
   Ma : string;
   Mi1 : string;
   Mi2 : string;
   N : LONGLONG;
   B : integer;
   R : string;
begin
Ma := ' دينار';
Mi1 := ' فلـ';
Mi2 := 'ـس';

N := Trunc(StrToFloat(X));
B := StrToInt(Copy(trim(FormatFloat('00000000000000.000',StrToFloat(X))),16,3));

R := SHorof(N);
if (R <> '') And (B > 0) Then Result := R + Ma + ' و ' + Mi1+IntToStr(B)+Mi2;
if (R <> '') And (B = 0) Then Result := R + Ma;
if (R = '') And (B <> 0) Then Result := Mi1+IntToStr(B)+Mi2;
Horof := Result;
end;

function SHorof(X: Real): string;
var
   N : LONGLONG;
   C : string;
   C1 : integer;
   C2 : integer;
   C3 : integer;
   C4 : integer;
   C5 : integer;
   C6 : integer;
   C7 : integer;
   Letter1 : string;
   Letter2 : string;
   Letter3 : string;
   Letter4 : string;
   Letter5 : string;
   Letter6 : string;
   Letter7 : string;
begin
N := Trunc(X);
C := Copy(format('%14d',[N]),1,14);
while Pos(' ', C) > 0 do
    C[Pos(' ', C)] := '0';
C1 := StrToInt(Copy(C, 14, 1));
case C1 of
1: Letter1 := 'واحد';
2: Letter1 := 'اثنان';
3: Letter1 := 'ثلاثة';
4: Letter1 := 'اربعة';
5: Letter1 := 'خمسة';
6: Letter1 := 'ستة';
7: Letter1 := 'سبعة';
8: Letter1 := 'ثمانة';
9: Letter1 := 'تسعة';
end;

C2 := StrToInt(Copy(C, 13, 1));
case C2 of
1: Letter2 := 'عشر';
2: Letter2 := 'عشرون';
3: Letter2 := 'ثلاثون';
4: Letter2 := 'اربعون';
5: Letter2 := 'خمسون';
6: Letter2 := 'ستون';
7: Letter2 := 'سبعون';
8: Letter2 := 'ثمانون';
9: Letter2 := 'تسعون';
end;

if (Letter1 <> '') And (C2 > 1) Then Letter2 := Letter1 + ' و' + Letter2;
if Letter2 = '' Then Letter2 := Letter1;
if (C1 = 0) And (C2 = 1) Then Letter2 := Letter2 + 'ة';
if (C1 = 1) And (C2 = 1) Then Letter2 := 'احدى عشر';
if (C1 = 2) And (C2 = 1) Then Letter2 := 'اثنى عشر';
if (C1 > 2) And (C2 = 1) Then Letter2 := Letter1 + ' ' + Letter2;
C3 := StrToInt(Copy(C, 12, 1));
case C3 of
1: Letter3 := 'مائة';
2: Letter3 := 'مئتان';
3..9: Letter3 := Copy(THorof(C3),1, Length(THorof(C3)) - 1) + 'مائة';
end;

if (Letter3 <> '') And (Letter2 <> '') Then Letter3 := Letter3 + ' و' + Letter2;
if Letter3 = '' then Letter3 := Letter2;

C4 := StrToInt(Copy(C, 9, 3));
Case C4 of
1: Letter4 := 'الف';
2: Letter4 := 'الفان';
3..10: Letter4 := THorof(C4) + ' آلاف';
11..999: Letter4 := THorof(C4) + ' الف';
end;

if (Letter4 <> '') And (Letter3 <> '') then Letter4 := Letter4 + ' و' + Letter3;
if Letter4 = '' then Letter4 := Letter3;
C5 := strToInt(Copy(C, 6, 3));
Case C5 of
1: Letter5 := 'مليون';
2: Letter5 := 'مليونان';
3..10: Letter5 := THorof(C5) + ' ملايين';
11..999: Letter5 := THorof(C5) + ' مليون';
end;
if (Letter5 <> '') And (Letter4 <> '') Then Letter5 := Letter5 + ' و' + Letter4;
if Letter5 = '' Then Letter5 := Letter4;

C6 := StrToInt(Copy(C, 3, 3));
Case C6 of
1: Letter6 := 'مليار';
2: Letter6 := 'ملياران';
3..999: Letter6 := THorof(C6) + ' مليار';
end;
if (Letter6 <> '') And (Letter5 <> '') Then Letter6 := Letter6 + ' و' + Letter5;
if Letter6 = '' Then Letter6 := Letter5;
C7 := StrToInt(Copy(C, 1, 2));
Case C7 of
1: Letter7 := 'بليون';
2: Letter7 := 'بليونان';
3..99: Letter7 := THorof(C7) + ' بليون';
end;
if (Letter7 <> '') And (Letter6 <> '') Then Letter7 := Letter7 + ' و' + Letter6;
if Letter7 = '' Then Letter7 := Letter6;
Result := Letter7;
end;

function THorof(X: Real): string;
var
   N : Longint;
   C : string;
   C1 : integer;
   C2 : integer;
   C3 : integer;
   Letter1 : string;
   Letter2 : string;
   Letter3 : string;
begin
N := Trunc(X);
C := Copy(format('%14d',[N]),1,14);
while Pos(' ', C) > 0 do
    C[Pos(' ', C)] := '0';
C1 := StrToInt(Copy(C, 14, 1));
case C1 of
1: Letter1 := 'واحد';
2: Letter1 := 'اثنان';
3: Letter1 := 'ثلاثة';
4: Letter1 := 'اربعة';
5: Letter1 := 'خمسة';
6: Letter1 := 'ستة';
7: Letter1 := 'سبعة';
8: Letter1 := 'ثمانية';
9: Letter1 := 'تسعة';
end;

C2 := StrToInt(Copy(C, 13, 1));
case C2 of
1: Letter2 := 'عشر';
2: Letter2 := 'عشرون';
3: Letter2 := 'ثلاثون';
4: Letter2 := 'اربعون';
5: Letter2 := 'خمسون';
6: Letter2 := 'ستون';
7: Letter2 := 'سبعون';
8: Letter2 := 'ثمانون';
9: Letter2 := 'تسعون';
end;

if (Letter1 <> '') And (C2 > 1) Then Letter2 := Letter1 + ' و' + Letter2;
if Letter2 = '' Then Letter2 := Letter1;
if (C1 = 0) And (C2 = 1) Then Letter2 := Letter2 + 'ة';
if (C1 = 1) And (C2 = 1) Then Letter2 := 'احدى عشر';
if (C1 = 2) And (C2 = 1) Then Letter2 := 'اثنى عشر';
if (C1 > 2) And (C2 = 1) Then Letter2 := Letter1 + ' ' + Letter2;

C3 := StrToInt(Copy(C, 12, 1));
case C3 of
1: Letter3 := 'مائة';
2: Letter3 := 'مئتان';
3..9: Letter3 := Copy(THorof(C3),1, Length(THorof(C3)) - 1) + 'مائة';
end;

if (Letter3 <> '') And (Letter2 <> '') Then Letter3 := Letter3 + ' و' + Letter2;
if Letter3 = '' then Letter3 := Letter2;

Result := Letter3;
end;

end.

إذا ساء فعل المرء ساءت ظنونه - أبو الطيب المتنبي

إذا ساء فعلُ المرء ساءت ظنونه     وصدّق ما يعتاده من توهمِ
وعادى محبّيه بقول عداته     وأصبحَ في ليلٍ من الشك مُظلمِ
أصادق نفس المرء من قبل جسمِه     وأعرفها في فعله والتكلمِ
وأحلم عن خلّي وأعلم أنه     متى أجزه حلمًا على الجهلِ يندمِ
وإن بذل الإنسانُ لي جود عابسٍ     جزيتُ بجود التارك المتبسِّمِ

أبو الطيب المتنبي