网上找了一圈都没发现完美的,尤其是在XE系列下。
发现这个写法还是比较满意的,特分享。
function THxsdj.UPRMB(val: Double): string; {人民币转大写函数}
var
Dig, Dpos, retVal, retValjf: string;
IntPart: array [0 .. 9] of Integer;
Vtemp, Icount: Integer;
Vjf: Integer;
Lastzh: string;
begin
Dig := '零壹贰叁肆伍陆柒捌玖';
Dpos := '元拾佰仟万拾佰仟亿拾佰仟万';
Icount := 0;
Vtemp := Round(val * 100); // Trunc(val);
Vtemp := Vtemp div 100;
Vjf := Round(val * 100) - Vtemp * 100;
while Vtemp > 0 do
begin
IntPart[Icount] := Vtemp mod 10;
Vtemp := Vtemp div 10;
Inc(Icount);
end;
Vtemp := 0;
while Icount > 0 do
begin
if IntPart[Icount - 1] <> 0 then
begin
if Vtemp > 0 then
retVal := retVal + copy(Dig, 1, 1);
retVal := retVal + copy(Dig, 1 + IntPart[Icount - 1] * 1, 1) +
copy(Dpos, 1 + (Icount - 1) * 1, 1);
Vtemp := 0;
end
else
begin
if (Icount = 1) or (Icount = 5) or (Icount = 9) or (Icount = 12) then
retVal := retVal + copy(Dpos, 1 + (Icount - 1) * 1, 1);
Inc(Vtemp);
end;
Dec(Icount);
end;
Dig := '零壹贰叁肆伍陆柒捌玖';
Dpos := '分角';
Icount := 0;
Vtemp := Vjf; // Trunc(val);
if Round((Vjf div 10) * 10) = Round((Vjf / 10) * 10) then
Lastzh := '整';
while Vtemp > 0 do
begin
IntPart[Icount] := Vtemp mod 10;
Vtemp := Vtemp div 10;
Inc(Icount);
end;
Vtemp := 0;
while Icount > 0 do
begin
if IntPart[Icount - 1] <> 0 then
begin
if Vtemp > 0 then
retValjf := retValjf + copy(Dig, 1, 1);
retValjf := retValjf + copy(Dig, 1 + IntPart[Icount - 1] * 1, 1) +
copy(Dpos, 1 + (Icount - 1) * 1, 1);
Vtemp := 0;
end
else
begin
Inc(Vtemp);
end;
Dec(Icount);
end;
Result := retVal + retValjf + Lastzh;
end;
0 条评论
沙发空缺中,还不快抢~