Sayıları yazı ile yazarken basamak ayrımı

[belizahmet]

Sayıları yazı ile yazdırmak için aşağıdaki kodu kullanıyorum.Fakat sayıların basamak değerlerini ayrı ayrı yazdırmak istiyorum.Örnek:26 sayısını yazarken farklı label içine Yirmi ve altı olarak yazsın.Bu işlem sadece yüze kadar olan sayılar için geçerli olacak.İşin içinden çıkamadım.
const'taki DIGER işimi karıştırıyor.1000'den büyük sayı da kullanmıyorum.

const
BIRLER: array[0..9] of string=('', 'Bir', 'İki', 'Üç', 'Dört', 'Beş', 'Altı',
'Yedi', 'Sekiz', 'Dokuz');
ONLAR : array[0..9] of string=('', 'On', 'Yirmi', 'Otuz', 'Kırk', 'Elli', 'Altmış',
'Yetmiş', 'Seksen', 'Doksan');
DIGER : array[0..5] of string=('', 'Bin', 'Milyon', 'Milyar', 'Trilyon', 'Katrilyon');


function SmallNum(N: Integer): string;
var
S: string[3];
begin
Result := '';
S := IntToStr(N);
if (Length(S)=1) then
S := '00' + S
else if (Length(S)=2) then
S := '0' + S;
if S[1]<>'0' then
if S[1]<>'1' then
Result := BIRLER[StrToInt(S[1])] + 'Yüz'
else
Result := 'Yüz';
Result := Result + ONLAR[StrToInt(S[2])];
Result := Result + BIRLER[StrToInt(S[3])];
end;

function NumStr(Num: Currency): string;
var
i, j, n, Nm: Integer;
S, Sn: string;
begin
S := FormatFloat('0', Num);
Sn := '';
if Num = 0 then
Sn := 'Sıfır'
else if Length(S) < 4 then
Sn := SmallNum(Round(Num))
else
begin
I := 1;
J := Length(S) mod 3;
if J=0 then
begin
J := 3;
N := Length(S) div 3 - 1;
end
else
N := Length(S) div 3;
while i<Length(S) do
begin
Nm := StrToInt(Copy(S, I, J));
if (Nm=1) and (N=1) then
begin
Nm := 0;
Sn := Sn + SmallNum(Nm) + Diger[N];
end;
if Nm<>0 then
Sn := Sn + SmallNum(Nm) + Diger[N];
I := I + J;
J := 3;
N := N - 1;
end;
end;
Result := Sn;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := NumStr(StrToCurr(Edit1.Text));
end;

[rsimsek]

Genelde fatura programlarında kullanılan şekilde sayıyı yazıya çeviren bir procedure yoksa da bulabilirsin. Daha sonra bahsettiğin sayıların tam sayı kısmını alıp ayrı ayrı yazdırmalısın

Örnek;

Kod: Tümünü seç

  sayi := 26;
  basamak := trunc(sayi / 10);
  YaziylaYazdir(basamak);
  basamak := sayi - basamak * 10;
  YaziylaYazdir(basamak);
...

gibi..

[aslangeri]

Merhaba...
@rsimsek in bahsettiği fatura programlarından birindeki yazıyı sayıya ceviren kod..
kolay gelsin.

Kod: Tümünü seç

unit sayi;
interface
//uses Wintypes,WinProcs,Classes,Forms;
var
  a,b,des:integer;
  r,Q:real;
  s,s2:string;
  Q1,Q2,Q3,Q4:string[3];
function sayicevir( s:string):string;

implementation
function bver(var s:char):string;
begin
 case s of
   '0':bver:='';
   '1':bver:='Bir ';
   '2':bver:='İki ';
   '3':bver:='Üç ';
   '4':bver:='Dört ';
   '5':bver:='Beş ' ;
   '6':bver:='Altı ';
   '7':bver:='Yedi ';
   '8':bver:='Sekiz ';
   '9':bver:='Dokuz ';
 end;   {case }
end;
function over(var s:char):string;
begin
 case s of
   '1':over:='On';
   '2':over:='Yirmi';
   '3':over:='Otuz';
   '4':over:='Kırk';
   '5':over:='Elli';
   '6':over:='Altmış';
   '7':over:='Yetmiş';
   '8':over:='Seksen';
   '9':over:='Doksan';
   '0':over:='';
 end;  {case }
end;
function uclu(ts:string):string;
var
  ba:byte;
  s1:string;
begin
  s1:=' ';
  ba:=length(ts);
  if ts[1]='0'  then ba:=2;
  if (ts[1]='0') and (ts[2]='0') then ba:=1;
  case ba of
    1: s1:=bver(ts[3]);
    2: begin
         s1:=bver(ts[3]);
         s1:=over(ts[2])+s1;
       end;
    3: begin
         s1:=bver(ts[3]);
         s1:=over(ts[2])+s1;
         if ts[1]='1' then s1:='Yüz'+s1
                      else s1:=bver(ts[1])+'Yüz'+s1;
       end;
  end;   { case}
  uclu:=s1;
end;
function sayicevir( s:string):string;
var
  b:byte;
begin
  Q1:=' ';Q2:=' ';Q3:=' ';Q4:=' ';
  s2:=' ';
  a:=12;
  if pos('.',s)>0 then
     delete(s,pos('.',s),(length(s)-pos('.',s)+1));
  des:=length(s);
  for b:=12-length(s) doWnto 1 do
      s:='0'+s;
  Q1:=copy(s,a-2,3);
  s2:=uclu(Q1);
  if des > 3 then
  begin
    Q2:=copy(s,a-5,3);
    if (des >6) and (Q2='000') then s2:=''+ s2 else
       if Q2='001' then s2:='Bin'+s2 else  s2:=uclu(Q2)+'Bin'+s2;
  end;
  if des>6  then
  begin
    Q3:=copy(s,a-8,3);
    if Q3>'000' then
    s2:=uclu(Q3)+'Milyon' +s2;
  end;
  if des>9 then
  begin
    Q4:=copy(s,a-11,3);
    if Q4>'000' then s2:=uclu(Q4)+'Milyar' +s2;
  end;
  sayicevir:=s2;
end;



begin
end.

[derya]

Böyle galiba daha basit:

Kod: Tümünü seç

function ToWordsInt(value: int64; zero: string): string;
const
  FirstNumbers      : array[0..19] of string =
                            ('', 'Bir', 'İki', 'Üç', 'Dört', 'Beş', 'Altı', 'Yedi', 'Sekiz', 'Dokuz');
  Tens                  : array[1..9] of string =
                            ('On', 'Yirmi', 'Otuz', 'Kırk', 'Elli', 'Altmış', 'Yetmiş', 'Seksen', 'Doksan'); 

  TenPot            : array[1..5] of string =
                            ('Bin', 'Milyon', 'Milyar', 'Trilyon', 'Katrilyon'); 

  function ToWordsRec(n: int64): string;
  var
    d               : int64;
    n2              : int64;
  begin
    case n of
      0..9:
        result := FirstNumbers[n];
      10..99:
        result := Tens[n div 10] + ' ' + ToWordsRec(n mod 10);
      100..199:
        result := 'yüz ' + ToWordsRec(n mod 100);
      200..999:
        result := FirstNumbers[n div 100] + ' yüz ' + ToWordsRec(n mod 100);
    else begin
        d := trunc(log10(n)) div 3;
        n2 := trunc(power(10 , d * 3));
        result := ToWordsRec(n div n2) + ' ' +
          TenPot[d] + ' ' + ToWordsRec(n mod n2);
      end;
    end;
  end;

begin
  if value = 0 then
    result := zero
  else
    result := ToWordsRec(value);
end;

function ToWords(value: Extended; removeDecimal: boolean = false): string;
begin
  result := ToWordsInt(Trunc(Value) , 'sıfır');
  if not RemoveDecimal then
    result := result + ' virgül ' +
      ToWordsInt(round(100 * frac(value)) , '00');
end;

uses'e math eklemeniz gerekiyor.

[belizahmet]

Sayın rsimsek beye ve diğer arkadaşlara çok teşekkürler.
Kullandığım procedure ?ü aşağıdaki gibi değiştirince istediğim sonucu aldım.

procedure TForm1.Button1Click(Sender: TObject);
var
sayi:integer;
bas:integer;
begin
Label1.Caption := NumStr(StrToCurr(Edit1.Text));
sayi := trunc(strtoint(edit1.Text)/ 10);
bas:=sayi*10;
Label2.Caption := NumStr(StrToCurr(inttostr(bas)));
sayi :=( strtoint(edit1.Text) - sayi * 10);
Label3.Caption := NumStr(StrToCurr(inttostr(sayi)));
end;