نوشتن اعداد به حروف

[ali643]

سلام

چه طوری میشه وقتی ما یه عدد رو مینویسیم (111111) به حروف در یک قسمت دیگه تایپ شود به صورت اتوماتیک


12134
دوازده هزار و صد و سی و چهار

[Kambiz]

جستجو رو فراموش نکنید!

http://www.barnamenevis.org/forum/viewtopic.php?t=2913

[ali643]

مرسی آقا کامبیز :wink:

[ali643]

سلام

من این کد رو تست کردم درست کار میده و لی وقتی می خواهد در یک لیبل تا edit و .. نشان بدهد بر عکس متن را می نویسد
به نظر شما چه دردی داره

[ali643]

راستی اینم یونیت برنامه


unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Label_Famil: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation
{$R *.dfm}

function num2str_pro(w:longint):string;
const
ch1:array[1..9] of string[10]=(' یک',' دو',' سه',' چهار',' پنج',' شش',' هفت',' هشت',' نه');
ch2:array[0..9] of string[10]=(' ده',' یازده',' دوازده',' سیزده¨',' چهارده',' پانزده',' شانزده',' هفده',' هجده',' نوزده');
ch3:array[1..8] of string[10]=(' بیست',' سی',' چهل',' پنجاه',' شصت',' هفتاد',' هشتاد',' نود');
ch4:array[1..9] of string[10]=(' صد',' دویست',' سیصد',' چهارصد',' پانصد',' ششصد',' هفتصد',' هشتصد',' نهصد');
ch5:array[2..4] of string[10]=(' هزار',' میلیون',' میلیارد');
var
org,scr,tem:string;
cont,i:byte;
cone,cten,chan:byte;

function zero(s:string):boolean;
var i:integer;w:word;
begin
if (s='') then zero:=false else zero:=true;
end;
begin
str(w,tem);cont:=0;
while length(tem) mod 3 <> 0 do
tem:='0'+tem;
cont:=length(tem) div 3;
org:='';i:=0;
while true do begin
if i=0 then inc(i) else inc(i,3);
if i>=length(tem) then break;
scr:=Copy(tem,i,3);
cone:=byte(scr[3])-48;
cten:=byte(scr[2])-48;
chan:=byte(scr[1])-48;
scr:='';
if(cone=0)and(cten=0)and(chan=0) then begin dec(cont);continue;end;
if zero(org) then
org:=' و '+org;
if (chan<10)and (chan>0) then
scr:=ch4[chan];
if (zero(scr)) and (cten<>0) then
scr:=' و '+scr;
if cten=1 then
begin
if cone<10 then
scr:=ch2[cone]+scr;
if (cont>1)and(cont<5) then
scr:=ch5[cont]+scr;
org:=scr+org;
dec(cont);
Continue;
end;
if (cten<>1)and (cten<10) and (cten>0)then
scr:=ch3[cten-1]+scr;
if (zero(scr)) and (cone <>0) and (cten<>1) then
scr:=' و '+scr;
if (cten<>1)and(cone<10)and(cone>0) then
scr:=ch1[cone]+scr;
if (cont>1)and(cont<5) then
scr:=ch5[cont]+scr;
dec(cont);
org:=scr+org;
end;
num2str_pro:=org;
end;

procedure TForm1.Button1Click(Sender: TObject);
Var
Nu:Longint;
begin
Nu:=StrToInt(Edit1.Text);
Label_Famil.Caption:=(num2str_pro(nu));
end;

end.
هر مشکلی بود لطف کنید بفرمایید که فوری هستااااااااااااا :wink:

[SyntaxCheck]

سلام
این فانکشن رو هم من نوشتم. امیدوارم که بدرد دوستان بخوره. این فانکشن همونطوری که میبینید ورودی Extended داره و اعداد اعشار رو هم میخونه، به همراه ممیز.
پیروز باشید


function AliHgethoroof(i:Extended):string;
const v=' و ';
var
ok:boolean;
j: Int64;
{___________________________________}
function yekan(y:byte):string;
begin
case y of
0:result:='';
1:result:='یک';
2:result:='دو';
3:result:='سه';
4:result:='چهار';
5:result:='پنج';
6:result:='شش';
7:result:='هفت';
8:result:='هشت';
9:result:='نه';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function dahgan(y:byte):string;
begin
case y of
0:result:='';
1:result:='ده';
2:result:='بیست';
3:result:='سی';
4:result:='چهل';
5:result:='پنجاه';
6:result:='شصت';
7:result:='هفتاد';
8:result:='هشتاد';
9:result:='نود';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function sadgan(y:byte):string;
begin
case y of
0:result:='';
1:result:='یکصد';
2:result:='دویست';
3:result:='سیصد';
4:result:='چهارصد';
5:result:='پانصد';
6:result:='ششصد';
7:result:='هفتصد';
8:result:='هشتصد';
9:result:='نهصد';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function dah(y:byte):string;
begin
case y of
0:result:='';
10:result:='ده';
11:result:='یازده';
12:result:='دوازده';
13:result:='سیزده';
14:result:='چهارده';
15:result:='پانزده';
16:result:='شانزده';
17:result:='هفده';
18:result:='هجده';
19:result:='نوزده';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function seragham(si:smallint):string;
begin
result:='';
result:=sadgan(si div 100);
if ok then result:=result+v;

if((si mod 100)div 10)<>1 then begin
result:=result+dahgan((si mod 100)div 10);
if ok then result:=result+v;
result:=result+yekan(si mod 10);
if not ok then result:=copy(result,1,length(result)-3);
End
else begin
result:=result+dah(si mod 100);
end;
if result='' then ok:=false else ok:=true;
end;
{___________________________________}
const
I_tr=' تریلیون';
I_mr=' میلیارد';
I_ml=' میلیون';
I_hz=' هزار';

FloatPoint: array [1..7] of String = (' دهم',' صدم',' هزارم',' ده هزارم'
,' صد هزارم',' میلیونیم',' ده میلیونیم');
var
jj: String;
begin
ok:=false;
if pos('.',FloatToStr(i)) <> 0 then
jj := copy( FloatToStr(i),1,pos('.',FloatToStr(i))-1)
else jj := FloatToStr(i);
j := StrToInt64Def(jj,0);
result:=seragham(j div 1000000000000);
if ok then result:=result+I_tr+v;
result:=result+seragham((j mod 1000000000000)div 1000000000);
if ok then result:=result+I_mr+v;
result:=result+seragham((j mod 1000000000)div 1000000);
if ok then result:=result+I_ml+v;
result:=result+seragham((j mod 1000000)div 1000);
if ok then result:=result+I_hz+v;
result:=result+seragham(j mod 1000);
if not ok then result:=copy(result,1,length(result)-3);

if pos('.',FloatToStr(i)) <> 0 then begin
Result := Result + ' ممیز ';
jj := copy( FloatToStr(i),pos('.',FloatToStr(i))+1,100);
j := StrToInt64Def(jj,0);

result:=result + seragham(j div 1000000000000);
if ok then result:=result+I_tr+v;
result:=result+seragham((j mod 1000000000000)div 1000000000);
if ok then result:=result+I_mr+v;
result:=result+seragham((j mod 1000000000)div 1000000);
if ok then result:=result+I_ml+v;
result:=result+seragham((j mod 1000000)div 1000);
if ok then result:=result+I_hz+v;
result:=result+seragham(j mod 1000);
if not ok then result:=copy(result,1,length(result)-3);

Result := Result + FloatPoint[length(JJ)];
end;

if i=0 then result:='صفر';
end;

[ali643]

SyntaxCheck عزیز ممنونم
کارم راه افتاد
اگه خودت برا مقادیر اعشاری چک کنی ممنون می شم چون error میده
:kiss:

[SyntaxCheck]

سلام
جان اکثر برنامه های من به این فانکشن گره خورده :wink:. با اینکه اطمینان به عملکردش دارم بنا به درخواست شما باز هم از همینجا فانکشن رو کپی کردم و تست کردم و به من که درست جواب داد. توجه به رنج عدد ورودی که در فانکشن تعریف شده داشته باشید. من نمیدونم شما چه اروری دریافت میکنید اما توجه کنید که این فانکشن اعداد اعشاری تا 7 رقم اعشار رو میتونه بخونه(همونطور که در تعریف FloatPoint میبینید).همینطور در مورد محدودیت تعداد ارقام صحیح که تا تریلیون تعریف شده.اما با کمی تغییر خودتون میتونید در صورت نیاز این محدوده رو افزایش بدید. به هر حال بگید که دقیقا چه ایرادی دریافت میکنید شاید بتونم کمکتون کنم.

[jirjirakk]

علی آقا تشکر :flower:

[ali643]

جیرجیرک جون از چی تشکر می کنی :متفکر:

[jirjirakk]

:D
از شما هم تشکر میکنم علی آقا که باعث و بانی خیر شدی (آخه اسمه سینتکس خان هم علی هستش ) :P

[jirjirakk]

:D

[Delphi KDE]

من هم از SyntaxCheck واقعا ممنونم
من که تست کردم عالی بود و هیچ خطایی با مقادیر اعشاری نداشت

[Delphi-Clinic]

دوست عزیزم اقای SyntaxCheck

متشکرم :)

[ali643]

من هم 100٪ کار داد عالی بود
اشتباه از من بود .تایپ کرده بودمstrtoint به جای StrToFloat
خیلی ممنون علی آقا
:kiss: :flower: