أداة تفقيـــط الأرقام Number To Letters

شكرا لك ولكن هاهنا أمران

الأول اكثر اعمال الفوترة ستكون بغير الأعداد الصحيحة اي بالأعداد العشرية مثل 52,50 دج لذلك سيكون العمل ناقصا بهذا الشكل

الثاني لو أرفقت السورس ليستفيد منه الأعضاء ما دام برنامجك مجانيا (مجرد اقتراح :happy: )

ولكي أفيدك وأفيد من يطلع على الموضوع فهاك الكود الذي يحول الأرقام الصحيحة الموجبة integer والارقام العشرية double إلى حروف

unit NToLettre;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;
function NombreEnToutesLettres(n : integer) : string;
function MontantEnToutesLettres(f : double) : string;

implementation
function NombreEnToutesLettres(n : integer) : string;
Const
  unite : array[1..16] of string  = ('un','deux','trois','quatre','cinq','six',
                                     'sept','huit','neuf','dix','onze','douze',
                                     'treize','quatorze','quinze','seize');
  dizaine : array[2..8] of string = ('vingt','trente','quarante','cinquante',
                                     'soixante','','quatre-vingt');
  coefs : array[0..3] of string   = ('cent','mille','million','milliard');
Var
  temp    : string;
  c, d, u : byte;
  coef    : byte;
  i       : word;
  neg     : boolean;
Begin
  If n = 0 then begin
    Result := ' zéro';
    exit;
  end;

  Result := '';
  neg := n < 0;
  If neg then n := -n;

  coef:=0;
  Repeat
    u:=n mod 10; n:=n div 10; {Récupère unité et dizaine}
    d:=n mod 10; n:=n div 10; {Récupère dizaine}
    If d in [1,7,9] then begin
      Dec(d);
      Inc(u, 10);
    end;
    temp := '';
    if d > 1 then begin
      temp := Dizaine[d];
      if (d < 8) and ((u = 1) or (u = 11)) then
        temp := temp + ' et';
    end;
    if u > 16 then begin
      if temp = '' then
        temp := unite[10]
      else
        temp := temp + ' ' + unite[10];
      Dec(u, 10);
    end;
    if u > 0 then begin
      if temp <> '' then
        temp := temp + ' ';
	    temp := temp + unite;
    end;
    If (d = 8) and (u = 0) and ((Result = '') or (LeftStr(Result, 6) = ' milli')) then
	    Result := 's' + Result;
    Result := temp + Result;

    c := n mod 10; n := n div 10; {Récupère centaine}
    If c > 0 then begin
      temp := '';
      if c > 1 then
	      temp := unite[c] + ' ';
      temp := temp + coefs[0];
      if (Result <> '') and (LeftStr(Result, 1) <> ' ') then
        Result := ' ' + Result;
      if (c > 1) and ((Result = '') or (LeftStr(Result, 6) = ' milli')) then
        Result := 's' + Result;
      Result := temp + Result;
    end;

    if n > 0 then begin
      Inc(coef);
      I := n mod 1000;
      If (Result <> '') and (LeftStr(Result, 1) <> ' ') then
	      Result := ' ' + Result;
      If (i > 1) and (coef > 1) then
	      Result := 's' + Result;
      If i > 0 then
        Result := ' ' + coefs[coef] + Result;
      If (i = 1) and (coef = 1) then
  	    Dec(n);
    end;
  until n = 0;
  Result := Trim(Result);
  if neg then
    Result := 'moins ' + Result;
End;
//==============================================================================
function MontantEnToutesLettres(f : double) : string;
const
  Centieme = 'centime';
  Monnaie = 'DZ';
var
  i : Integer;
begin
  Result := '';

  // partie décimale
  i := Round(Frac(f) * 100);
  if i > 0 then begin // n'écrit pas "zéro centime" si partie décimale nulle
    if i > 1 then
      Result := 's';
    Result := ' ' + NombreEnToutesLettres(i) + ' ' + Centieme + Result;
  end;

  // partie entière
  i := Trunc(f);
  if i > 1 then
    Result := 's' + Result;
  Result := NombreEnToutesLettres(i) + ' ' + Monnaie + Result;
end;
end.

ما عليك الآن إلا ضم هذه الوحدة إلى برنامجك وتعديله ليصبح كاملا

تحية وسلاما

إليكم نسخة من هذه الوحدة  تعمل حتى مع الارقام العشرية

و لكن باللغة العربية فقط :

unit Number2String;
// دالة التفقيط الآلي
// برمجة محمد مهند عبادي 2003
// أضاف بعض التنقيحات  م.عادل الرميثه

interface

uses SysUtils,StrUtils;

Function words(Number : Double; F1 : String = 'واحدة'; F2 :String = 'واحدتين' ; F3 : String = 'واحدات'
; D1 : String = 'جزء' ; D2 : String = 'جزئين'; D3: String = 'أجزاء'; SayJust : Boolean = True) : String;
implementation

Function words(Number : Double; F1 : String = 'واحدة'; F2 :String = 'واحدتين' ; F3 : String = 'واحدات'
; D1 : String = 'جزء' ; D2 : String = 'جزئين'; D3: String = 'أجزاء'; SayJust : Boolean = True) : String;
Var
  P,P1,P2,P3,P4,w,w1,w2,w3,N,n1 : String;
  SD : Int64;
(*------------------------------------------------------------------------*)
  Function Swords(N, U1, U2, U3 : String) : String;
  Type
    TF = array[0..2,0..9] of String;
  Const
    FNO : TF = (('','واحد','إثنان','ثلاثة','أربعة','خمسة','ستة','سبعة','ثمانية','تسعة'),
              ('','عشر','عشرون','ثلاثون','أربعون','خمسون','ستون','سبعون','ثمانون','تسعون'),
              ('','مائة','مائتين','ثلاثمائة','أربعمائة','خمسمائة','ستمائة','سبعمائة','ثمانمائة','تسعمائة'));
  Var
    s: array[1..3] of Byte;
    PU : array[0..2] of String;
    A : Tf;
    w1,w2,f : String;
    E : integer;
  Begin
    A := FNO;
    Pu[0] := '';
    PU[1] := U1 ;
    Pu[2] := U2 ;
    E := StrToInt(N);
    If E < 3 then  Swords := pu[E]
    Else
      Begin
        N := leftstr('000',3-length(n)) + N ;
        For E := 1 to 3 Do S[E] := StrToInt(n[4-E]);
        If (s[2] = 0) or (s[1] = 0) Then W2 := '' Else W2 := ' و ';
        If (s[3] = 0) Or (s[1]+S[2] = 0) Then W1 := '' Else W1 := ' و ';
        If S[2] = 1 Then
          Begin
            A[0,1] := 'أحد ';
            A[0,2] := 'إثنا ' ;
            W2 := ' ';
          End;

        Case strToInt(n[2]+n[3]) of
          0 : Begin
                A[2, 2] := 'مائتا ';
                F := U1;
              End;
          3..10 :    F := U3;
          1,2, 11..99 : F := U1;
        end;
        swords := A[2, S[3]] + w1 + A[0, S[1]] + w2 + A[1, S[2]] + ' ' + F;
      End;
  End;
(*------------------------------------------------------------------------*)
Begin
  If Number > 0 Then
    Begin
      Sd := Trunc(Number);
      p := Swords(inttostr(round((Number-sd)*100)),D1,D2,D3);
      N := leftstr('000000000000',12-length(floattostr(Sd))) + floattostr(Sd) ;
      P1 := Swords(Copy(N, 10, 3), F1, F2, F3);
      P2 := Swords(Copy(N, 7, 3), 'ألف', 'ألفان', 'آلاف');
      P3 := Swords(copy(N, 4, 3), 'مليون', 'مليونان', 'ملايين');
      P4 := Swords(copy(N, 1, 3), 'مليار', 'ملياران', 'مليارات');
      If (P4 = '') Or (P1 + P2 + P3 = '') Then w3 := '' Else w3 := ' و ';
      If (P3 = '') Or (P1 + P2 = '') Then w2 := '' Else w2 := ' و ';
      If (P2 = '') Or (P1 = '') Then w1 := '' Else w1 := ' و ';
      If P1 = '' Then P1 := ' ' + F1;
      If P = '' Then w := '' Else w := ' و ';
      if Sd = 0 then
      N :=  P
      else
      N := P4 + w3 + P3 + w2 + P2 + w1 + P1 + w + P;
      If SayJust Then words := 'فقط ' + N + ' لاغير'Else Words := N;
    end;

End;

end.
 

أخي ميكروسمارت  جزاك الله خيرا

ولكن لو استعملت خاصة إدراج كود حتى يتم تنسيق الوحدة أو ارفعها في المرفقات