function Change(const S: string): string; var Ext:Extended; TempStr,LeftStr,RightStr:string; Function ChangeNum(Num:char):string; begin case Num of '0':Result:='零'; '1':Result:='壹'; '2':Result:='贰'; '3':Result:='叁'; '4':Result:='肆'; '5':Result:='伍'; '6':Result:='陆'; '7':Result:='柒'; '8':Result:='捌'; '9':Result:='玖'; else Result:='?'; end; end; Function GetDW(DW:Byte):string; begin case DW of 1:Result:=''; 2:Result:='拾'; 3:Result:='佰'; 4:Result:='仟'; else Result:='?'; end; end; Function GetDanWei(DanWei:Byte):string ; begin Case DanWei of 1:Result:='元'; 2:Result:='万'; 3:Result:='亿'; else Result:='?'; end; end; Function GetShortStr(SS:string;Sep:byte):string; var IsNotZero:boolean; N:byte; begin Result:=''; for N:=Length(SS) Downto 1 do begin case SS[N] of '0':begin if IsNotZero then Result:=ChangeNum(SS[N])+Result; IsNotZero:=false; end; '1'..'9':begin Result:=ChangeNum(SS[N])+GetDW(Length(SS)+1-N)+Result; IsNotZero:=true; end; end; end; if (Result<>'') or (Sep=1) then Result:=Result+GetDanWei(Sep) else Result:=''; end; Function ChangeRight(const RS:string):string; var FenStr:string; begin if (RS[1]='0') and (RS[2]='0') then begin Result:=''; Exit; end; if RS[2]<>'0' then FenStr:=ChangeNum(RS[2])+'分'; if RS[1]<>'0' then Result:=ChangeNum(RS[1])+'角'+FenStr else Result:=ChangeNum(RS[1])+FenStr; end; Function ChangeLeft(LS:string):string; var N,L:byte; TS:String; begin L:=((Length(LS)-1) div 4)+1; for N:=1 to L do begin if N=L then begin TS:=GetShortStr(LS,N)+TS end else begin TS:=GetShortStr(copy(LS,Length(LS)-3,4),N)+TS; LS:=Copy(LS,1,Length(LS)-4); end; end; Result:=TS; end;begin try Ext:=StrToFloat(S); except Application.MessageBox(pchar(S+'不是有效的金额'),'错误',MB_OK+MB_ICONSTOP); Exit; end; TempStr:=FormatFloat('0.00',Ext); RightStr:=copy(TempStr,Pos('.',TempStr)+1,Length(TempStr)); LeftStr:=copy(TempStr,1,Pos('.',TempStr)-1); Result:=ChangeLeft(LeftStr)+ChangeRight(RightStr)+'整'; end;
Function XiaoxieToDaxie(f : String) : String; var Fs,dx,d2,zs,xs,h,jg:string; i,ws,{l,}w,j,lx:integer; begin f := Trim(f); if copy(f,1,1)='-' then begin Delete(f,1,1);fs:='负';end else fs:=''; dx:='零壹贰叁肆伍陆柒捌玖'; d2:='拾佰仟万亿'; i := AnsiPos('.',f); //小数点位置 if i = 0 Then zs := f //整数 else begin zs:=copy(f,1,i - 1); //整数部分 xs:=copy(f,i + 1,200); end; ws:= 0; //l := 0; for i := Length(zs) downto 1 do begin ws := ws + 1; h := ''; w:=strtoint(copy(zs, i, 1)); if (w=0) and (i=1) then jg:='零'; If w > 0 Then Case ws of 2..5:h:=copy(d2,(ws-1)*2-1,2); 6..8:begin h:=copy(d2,(ws-5)*2-1,2); If AnsiPos('万',jg)=0 Then h:=h+'万'; end; 10..13:h := copy(d2,(ws-9)*2-1, 2); End; jg:=copy(dx,(w+1)*2-1,2) + h + jg; If ws=9 Then jg := copy(jg,1,2) + '亿' + copy(jg,3,200); end; j:=AnsiPos('零零',jg); While j > 0 do begin jg := copy(jg, 1, j - 1) + copy(jg, j + 2,200); j := AnsiPos('零零',jg); end; If (Length(jg) > 1) And (copy(jg,length(jg)-1,2)='零') Then jg :=copy(jg,1,Length(jg)-2); j := AnsiPos('零亿',jg); If j > 0 Then jg := copy(jg,1, j - 1) + copy(jg, j + 2,200); //转换小数部分 lx := Length(xs); If lx > 0 Then begin jg := jg + '元'; For i := 1 To lx do begin if i=1 then begin jg := jg + copy(dx, strtoint(copy(xs,i,1))*2 + 1, 2); jg := jg +'角'; end; if i=2 then begin jg := jg + copy(dx, strtoint(copy(xs,i,1))*2 + 1, 2); jg := jg +'分'; end; end; j :=AnsiPos('零角零分',jg); if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+8,200)+'整'; j := AnsiPos('零角',jg); if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+4,200); j := AnsiPos('零分',jg); if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+4,200); End else jg := jg + '元整'; result := fs+jg; end;
Function NtoC( n0 :real) :String; Function IIF( b :boolean; s1,s2 :string) :string; begin if b then IIF:= s1 else IIF:=s2; end; //本函数的功能一目了然: 当b为真时返回s1,否则返回s2 Const c= '零壹贰叁肆伍陆柒捌玖◇分角圆拾佰仟万拾佰仟亿拾佰仟万'; var L,i,n, code :integer; Z :boolean; s,s1,s2 :string; begin s:= FormatFloat( '0.00', n0); L:= Length( s); Z:= n0<1; For i:= 1 To L-3 do begin Val( Copy( s, L-i-2, 1), n, code); s1:=IIf( (n=0) And (Z Or (i=9) Or (i=5) Or (i=1)), '', Copy( c, n*2+1, 2)) + IIf( (n=0) And ((i<>9) And (i<>5) And (i<>1) Or Z And (i=1)), '', Copy( c, (i+13)*2-1, 2)) + s1; Z:= (n=0); end; Z:= False; For i:= 1 To 2 do begin Val( Copy( s, L-i+1, 1), n, code); s2:= IIf( (n=0) And ((i=1) Or (i=2) And (Z Or (n0<1))), '', Copy( c, n*2+1, 2)) + IIf( (n>0), Copy( c,(i+11)*2-1, 2), IIf( (i=2) Or Z, '', '整')) + s2; Z:= (n=0); end; For i:= 1 To Length( s1) do If Copy(s1, i, 4) = '亿万' Then Delete(s1,i+2,2); NtoC:= IIf(n0=0, '零', s1+s2); End;
var
Ext:Extended;
TempStr,LeftStr,RightStr:string; Function ChangeNum(Num:char):string;
begin
case Num of
'0':Result:='零';
'1':Result:='壹';
'2':Result:='贰';
'3':Result:='叁';
'4':Result:='肆';
'5':Result:='伍';
'6':Result:='陆';
'7':Result:='柒';
'8':Result:='捌';
'9':Result:='玖';
else Result:='?';
end;
end; Function GetDW(DW:Byte):string;
begin
case DW of
1:Result:='';
2:Result:='拾';
3:Result:='佰';
4:Result:='仟';
else Result:='?';
end;
end; Function GetDanWei(DanWei:Byte):string ;
begin
Case DanWei of
1:Result:='元';
2:Result:='万';
3:Result:='亿';
else Result:='?';
end;
end; Function GetShortStr(SS:string;Sep:byte):string;
var
IsNotZero:boolean;
N:byte;
begin
Result:='';
for N:=Length(SS) Downto 1 do
begin
case SS[N] of
'0':begin
if IsNotZero then
Result:=ChangeNum(SS[N])+Result;
IsNotZero:=false;
end;
'1'..'9':begin
Result:=ChangeNum(SS[N])+GetDW(Length(SS)+1-N)+Result;
IsNotZero:=true;
end;
end;
end;
if (Result<>'') or (Sep=1) then
Result:=Result+GetDanWei(Sep)
else
Result:='';
end; Function ChangeRight(const RS:string):string;
var
FenStr:string;
begin
if (RS[1]='0') and (RS[2]='0') then
begin
Result:='';
Exit;
end;
if RS[2]<>'0' then
FenStr:=ChangeNum(RS[2])+'分';
if RS[1]<>'0' then
Result:=ChangeNum(RS[1])+'角'+FenStr
else
Result:=ChangeNum(RS[1])+FenStr;
end;
Function ChangeLeft(LS:string):string;
var
N,L:byte;
TS:String;
begin
L:=((Length(LS)-1) div 4)+1;
for N:=1 to L do
begin
if N=L then
begin
TS:=GetShortStr(LS,N)+TS
end
else
begin
TS:=GetShortStr(copy(LS,Length(LS)-3,4),N)+TS;
LS:=Copy(LS,1,Length(LS)-4);
end;
end;
Result:=TS;
end;begin
try
Ext:=StrToFloat(S);
except
Application.MessageBox(pchar(S+'不是有效的金额'),'错误',MB_OK+MB_ICONSTOP);
Exit;
end;
TempStr:=FormatFloat('0.00',Ext);
RightStr:=copy(TempStr,Pos('.',TempStr)+1,Length(TempStr));
LeftStr:=copy(TempStr,1,Pos('.',TempStr)-1);
Result:=ChangeLeft(LeftStr)+ChangeRight(RightStr)+'整';
end;
var
Fs,dx,d2,zs,xs,h,jg:string;
i,ws,{l,}w,j,lx:integer;
begin
f := Trim(f);
if copy(f,1,1)='-' then begin
Delete(f,1,1);fs:='负';end
else fs:='';
dx:='零壹贰叁肆伍陆柒捌玖';
d2:='拾佰仟万亿';
i := AnsiPos('.',f); //小数点位置
if i = 0 Then
zs := f //整数
else begin
zs:=copy(f,1,i - 1); //整数部分
xs:=copy(f,i + 1,200);
end;
ws:= 0; //l := 0;
for i := Length(zs) downto 1 do begin
ws := ws + 1; h := '';
w:=strtoint(copy(zs, i, 1));
if (w=0) and (i=1) then jg:='零';
If w > 0 Then
Case ws of
2..5:h:=copy(d2,(ws-1)*2-1,2);
6..8:begin
h:=copy(d2,(ws-5)*2-1,2);
If AnsiPos('万',jg)=0 Then h:=h+'万';
end;
10..13:h := copy(d2,(ws-9)*2-1, 2);
End;
jg:=copy(dx,(w+1)*2-1,2) + h + jg;
If ws=9 Then jg := copy(jg,1,2) + '亿' + copy(jg,3,200);
end;
j:=AnsiPos('零零',jg);
While j > 0 do begin
jg := copy(jg, 1, j - 1) + copy(jg, j + 2,200);
j := AnsiPos('零零',jg);
end;
If (Length(jg) > 1) And (copy(jg,length(jg)-1,2)='零') Then jg :=copy(jg,1,Length(jg)-2);
j := AnsiPos('零亿',jg);
If j > 0 Then jg := copy(jg,1, j - 1) + copy(jg, j + 2,200);
//转换小数部分
lx := Length(xs);
If lx > 0 Then begin
jg := jg + '元';
For i := 1 To lx do begin
if i=1 then begin
jg := jg + copy(dx, strtoint(copy(xs,i,1))*2 + 1, 2);
jg := jg +'角';
end;
if i=2 then begin
jg := jg + copy(dx, strtoint(copy(xs,i,1))*2 + 1, 2);
jg := jg +'分';
end;
end;
j :=AnsiPos('零角零分',jg);
if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+8,200)+'整';
j := AnsiPos('零角',jg);
if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+4,200);
j := AnsiPos('零分',jg);
if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+4,200);
End
else
jg := jg + '元整';
result := fs+jg;
end;
Function IIF( b :boolean; s1,s2 :string) :string;
begin if b then IIF:= s1 else IIF:=s2;
end; //本函数的功能一目了然: 当b为真时返回s1,否则返回s2
Const c= '零壹贰叁肆伍陆柒捌玖◇分角圆拾佰仟万拾佰仟亿拾佰仟万';
var L,i,n, code :integer; Z :boolean; s,s1,s2 :string;
begin
s:= FormatFloat( '0.00', n0);
L:= Length( s);
Z:= n0<1;
For i:= 1 To L-3 do
begin
Val( Copy( s, L-i-2, 1), n, code);
s1:=IIf( (n=0) And (Z Or (i=9) Or (i=5) Or (i=1)), '', Copy( c, n*2+1, 2))
+ IIf( (n=0) And ((i<>9) And (i<>5) And (i<>1) Or Z And (i=1)), '', Copy( c, (i+13)*2-1, 2))
+ s1;
Z:= (n=0);
end;
Z:= False;
For i:= 1 To 2 do
begin
Val( Copy( s, L-i+1, 1), n, code);
s2:= IIf( (n=0) And ((i=1) Or (i=2) And (Z Or (n0<1))), '', Copy( c, n*2+1, 2))
+ IIf( (n>0), Copy( c,(i+11)*2-1, 2), IIf( (i=2) Or Z, '', '整'))
+ s2;
Z:= (n=0);
end;
For i:= 1 To Length( s1) do If Copy(s1, i, 4) = '亿万' Then Delete(s1,i+2,2);
NtoC:= IIf(n0=0, '零', s1+s2);
End;