Dephi阿拉伯数字转换成英文和中文大写

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleServer, ExcelXP, comobj, Spin;

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Edit1: TEdit;
    Label1: TLabel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    SpinEdit1: TSpinEdit;
    SpinEdit2: TSpinEdit;
    SpinEdit3: TSpinEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private

    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  myexcel,myworkbook,mysheet:variant;
  glb,t1 :integer;
implementation

{$R *.dfm}
//------------------------
//将阿拉伯数字转成英文字串
//------------------------
function num2ceng(strArabic:string):string;//不带小数点英文转换中文
const
  sw:array[2..9]of string=('twenty','thirty','forty','fifty','sixty','seventy','eighty','ninety');
  gw:array[1..19] of string=('one','two','three','four','five','six','seven','eight','nine','ten','eleven','twelve','thirteen','fourteen','fifteen','sixteen','seventeen','eighteen','nineteen');
  exp:array[1..4] of string=('','thousand','million','billion');
var
  t,j:integer;
  ts:string;
  function readu1000(ss:string):string;
  var
    t,code:integer;
    begin
    result := '';
      while ss[1]='0' do
      begin
        delete(ss,1,1);
        if length(ss)=0 then exit;//控制全是0情况
      end;
    if length(ss)=3 then
      begin
        appendstr(result,gw[ord(ss[1])-ord('0')]);
        appendstr(result,' hundred ');
        delete(ss,1,1);
      end;
    while ss[1]='0' do
      begin
        delete(ss,1,1);
        if length(ss)=0 then exit;
      end;
   if length(ss)<>0 then
    if result <> '' then appendstr(result,'and ');
    if (glb = 1) and (t1<>1) then //超过百位时候处理最后3位
      if result='' then appendstr(result,'and ');
    begin
      val(ss,t,code);
      if t<20 then result :=result+gw[t]
      else if t mod 10=0 then result:=result+sw[t div 10]
      else result := result+sw[trunc(t/10)]+'-'+gw[t mod 10];
   end;
  end;
begin
  result :='Say ';
  t := pos('.',strArabic);
  if t=0 then t:=length(strArabic)+1;
  while (t mod 3<>1)do
    begin
        t:=t+1;
      strArabic:='0'+ strArabic;
    end;
  t1:=(t-1) div 3;
  for glb:=t1 downto 1 do
  begin
      ts:='';
      for j:=1 to 3 do
      begin
           ts:=ts+ strArabic[1];
        delete(strArabic,1,1);
      end;
    result := result + readu1000(ts);
    if ts<>'000' then result := result+' '+exp[glb]+' ';
  end;
  if length(strArabic)<>0 then
  begin
      delete(strArabic,1,1);
    appendstr(result,'and ');
    result :=result + readu1000(strArabic);
  end;
end;
function num2cengnum(strArabic:string):string;
const
  gw:array[1..10] of string =('0','one','two','three','four','five','six','seven','eight','nine');
var
  p,i,j,x:integer;
  s:string;
begin
   result := '';
   s := strarabic;
   p := pos('.',strarabic);
   if p = 0 then
    begin
      result := num2ceng(strarabic)+'Only';
      exit;
    end
   else
    begin
      i := length(s)-p;//计算小数点后面有几位
      delete(strarabic,p,i+1);//删除小数点后面数字
      result := num2ceng(strarabic)+'Point';
    end;
    for x:=1 to i do //转换小数点后面数字
      begin
        j:= strtoint(copy(s,p+x,1));
        case j of
          0: result := result +' '+gw[1];
          1: result := result +' '+gw[2];
          2: result := result +' '+gw[3];
          3: result := result +' '+gw[4];
          4: result := result +' '+gw[5];
          5: result := result +' '+gw[6];
          6: result := result +' '+gw[7];
          7: result := result +' '+gw[8];
          8: result := result +' '+gw[9];
          9: result := result +' '+gw[10];
        end;
      end;
end;
//-----------------------------------------
// Num2CNum  将阿拉伯数字转成中文数字字串
//------------------------------------------
function Num2CNum(dblArabic: double): string;
const
  _ChineseNumeric = '零壹贰叁肆伍陆柒捌玖';

var
  sArabic: string;
  sIntArabic: string;
  iPosOfDecimalPoint: integer;
  i: integer;
  iDigit: integer;
  iSection: integer;
  sSectionArabic: string;
  sSection: string;
  bInZero: boolean;
  bMinus: boolean;

  (* 将字串反向, 例如: 传入 '1234', 传回 '4321' *)
  function ConvertStr(const sBeConvert: string): string;
  var
    x: integer;
  begin
    Result := '';
    for x := Length(sBeConvert) downto 1 do
      AppendStr(Result, sBeConvert[x]);
  end; { of ConvertStr }
begin
  Result := '';
  bInZero := True;
  sArabic := FloatToStr(dblArabic); (* 将数字转成阿拉伯数字字串 *)
{$IFDEF __Debug}
  ShowMessage('FloatToStr(dblArabic): ' + sArabic);
{$ENDIF}
  if sArabic[1] = '-' then
    begin
      bMinus := True;
      sArabic := Copy(sArabic, 2, 254);
    end
  else
    bMinus := False;
  iPosOfDecimalPoint := Pos('.', sArabic); (* 取得小数点的位置 *)
{$IFDEF __Debug}
  ShowMessage('Pos(''.'', sArabic) ' + IntToStr(iPosOfDecimalPoint));
{$ENDIF}

  (* 先处理整数的部分 *)
  if iPosOfDecimalPoint = 0 then
    sIntArabic := ConvertStr(sArabic)
  else
    sIntArabic := ConvertStr(Copy(sArabic, 1, iPosOfDecimalPoint - 1));
  (* 从个位数起以每四位数为一小节 *)
  for iSection := 0 to ((Length(sIntArabic) - 1) div 4) do
    begin
      sSectionArabic := Copy(sIntArabic, iSection * 4 + 1, 4);
      sSection := '';
      (* 以下的 i 控制: 个十百千位四个位数 *)
      for i := 1 to Length(sSectionArabic) do
        begin
          iDigit := Ord(sSectionArabic[i]) - 48;
          if iDigit = 0 then
            begin
              (* 1. 避免 '零' 的重覆出现 *)
              (* 2. 个位数的 0 不必转成 '零' *)
              if (not bInZero) and (i <> 1) then sSection := '零' + sSection;
              bInZero := True;
            end
          else
            begin
              case i of
                2: sSection := '拾' + sSection;
                3: sSection := '佰' + sSection;
                4: sSection := '仟' + sSection;
              end;
              sSection := Copy(_ChineseNumeric, 2 * iDigit + 1, 2) +
                sSection;
              bInZero := False;
            end;
        end;

      (* 加上该小节的位数 *)
      if Length(sSection) = 0 then
        begin
          if (Length(Result) > 0) and (Copy(Result, 1, 2) <> '零') then
            Result := '零' + Result;
        end
      else
        begin
          case iSection of
            0: Result := sSection;
            1: Result := sSection + '万' + Result;
            2: Result := sSection + '亿' + Result;
            3: Result := sSection + '兆' + Result;
          end;
        end;

{$IFDEF __Debug}
      ShowMessage('sSection: ' + sSection);
      ShowMessage('Result: ' + Result);
{$ENDIF}
    end;

  (* 处理小数点右边的部分 *)
  if iPosOfDecimalPoint > 0 then
    begin
      AppendStr(Result, '元');
      {for i := iPosOfDecimalPoint + 1 to Length(sArabic) do
        begin
          iDigit := Ord(sArabic[i]) - 48;
          AppendStr(Result, Copy(_ChineseNumeric, 2 * iDigit + 1, 2));
        end;---没有限制小数点后面位置}
      i := iPosOfDecimalPoint + 1;
      iDigit := Ord(sArabic[i]) - 48;
      if Copy(_ChineseNumeric, 2 * iDigit + 1, 2) <> '零' then
        begin
          AppendStr(Result, Copy(_ChineseNumeric, 2 * iDigit + 1, 2));
          Result := Result+'角';
        end
      else
        begin
          AppendStr(Result, Copy(_ChineseNumeric, 2 * iDigit + 1, 2));
        end;
      i := i+1;
      iDigit := Ord(sArabic[i]) - 48;
      AppendStr(Result, Copy(_ChineseNumeric, 2 * iDigit + 1, 2));
      Result := Result+'分'
    end;

{$IFDEF __Debug}
  ShowMessage('Result before 其他例外处理: ' + Result);
{$ENDIF}
  (* 其他例外状况的处理 *)
  if Length(Result) = 0 then Result := '零';
  if Copy(Result, 1, 4) = '一十' then Result := Copy(Result, 3, 254);
  if Copy(Result, 1, 2) = '点' then Result := '零' + Result;
  if iposofdecimalpoint = 0 then result := result + '元整';
  (* 是否为负数 *)
  if bMinus then Result := '负' + Result;
{$IFDEF __Debug}
  ShowMessage('Result before Exit: ' + Result);
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  opendialog1.Execute;
  edit1.Text := opendialog1.FileName;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  introw,intnum,i,col1,col2,col3:integer;
  filename :string;
begin
  try
    if application.MessageBox('你确定要转换么？','信息提示：',mb_yesno+mb_defbutton1+mb_iconinformation)= idyes then
    begin
      if fileexists(edit1.Text) = false then
        begin
          showmessage('文件不存在，请重新选择文件');
          exit;
        end;
      myexcel:= CreateOleObject('Excel.Application');
      myworkbook := myexcel.workbooks.open(edit1.text);
      myexcel.Visible := false;
      mysheet := myexcel.worksheets[1];
      introw := mysheet.UsedRange.Rows.Count;//计算多少行
      col1 := spinedit1.Value;
      col2 := spinedit2.Value;
      col3 := spinedit3.Value;
      for i:=1 to introw do
        begin
          myexcel.cells[i,col2].value := Num2CNum(strtofloat(myexcel.cells[i,col1].value));
          myexcel.cells[i,col3].value := num2cengnum(myexcel.cells[i,col1].value);
        end;
      intnum :=length(extractfilename(edit1.Text))-4;
      filename :=extractfilepath(edit1.Text)+copy(extractfilename(edit1.text),1,intnum)+'1'+extractfileext(edit1.Text);
      if fileexists(filename) then
        showmessage('已经存在转换完成文件,不能重复转换!')
      else
        begin
          mysheet.saveas(filename);
          showmessage('恭喜,转换完成为'+filename);
        end;
      myexcel.quit;
    end;
  except
    showmessage('意外错误，查看是否选择正确文件和是否安装Excel');
    //myexcel.quit;
    myexcel := unassigned;
    exit;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  opendialog1.Execute;
  myexcel := createoleobject('excel.application');
  myexcel.visible := true;
  myexcel.workbooks.open(opendialog1.FileName);
end;

end.