tchmoneyimpl1.pas

一个通过传递一个值来填充下面数字的,可以用于收款发票上的帐款显示条,需要自己加包编译.

unit TChMoneyImpl1;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ActiveX, AxCtrls, TChMoneyProj1_TLB, StdVcl, StdCtrls, ExtCtrls;

type
  TTChMoney = class(TActiveForm, ITChMoney)
    Panel1: TPanel;
    Panel2: TPanel;
    Image1: TImage;
    Panel4: TPanel;
    Image2: TImage;
    Panel3: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    LblYi: TLabel;
    Lblqian: TLabel;
    LblBai: TLabel;
    LblShi: TLabel;
    LblWan: TLabel;
    LblQianXiao: TLabel;
    LblBaiXiao: TLabel;
    LblShiXiao: TLabel;
    LblYuan: TLabel;
    Lbljiao: TLabel;
    LblFen: TLabel;
    LblNo5: TLabel;
    LblNo8: TLabel;
    LblNo7: TLabel;
    LblNo6: TLabel;
    LblNo9: TLabel;
    lblNo4: TLabel;
    LblNo3: TLabel;
    lblNo2: TLabel;
    LblNo1: TLabel;
    LblNo_2: TLabel;
    LblNo_1: TLabel;
  private
    FMoney:single;
    { Private declarations }
    FEvents: ITChMoneyEvents;
    procedure ActivateEvent(Sender: TObject);
    procedure ClickEvent(Sender: TObject);
    procedure CreateEvent(Sender: TObject);
    procedure DblClickEvent(Sender: TObject);
    procedure DeactivateEvent(Sender: TObject);
    procedure DestroyEvent(Sender: TObject);
    procedure KeyPressEvent(Sender: TObject; var Key: Char);
    procedure PaintEvent(Sender: TObject);


   function GetChinaNumber(s:integer):string;
   procedure AddBit(i:integer;Save:string);
   procedure init;
   procedure GetResult(r:string);

  protected
    { Protected declarations }
    procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
    function Get_Active: WordBool; safecall;
    function Get_AlignDisabled: WordBool; safecall;
    function Get_AutoScroll: WordBool; safecall;
    function Get_AutoSize: WordBool; safecall;
    function Get_AxBorderStyle: TxActiveFormBorderStyle; safecall;
    function Get_Caption: WideString; safecall;
    function Get_Color: OLE_COLOR; safecall;
    function Get_DoubleBuffered: WordBool; safecall;
    function Get_DropTarget: WordBool; safecall;
    function Get_Enabled: WordBool; safecall;
    function Get_Font: IFontDisp; safecall;
    function Get_HelpFile: WideString; safecall;
    function Get_KeyPreview: WordBool; safecall;
    function Get_PixelsPerInch: Integer; safecall;
    function Get_PrintScale: TxPrintScale; safecall;
    function Get_Scaled: WordBool; safecall;
    function Get_ScreenSnap: WordBool; safecall;
    function Get_SnapBuffer: Integer; safecall;
    function Get_Visible: WordBool; safecall;
    function Get_VisibleDockClientCount: Integer; safecall;
    procedure _Set_Font(var Value: IFontDisp); safecall;
    procedure AboutBox; safecall;
    procedure Set_AutoScroll(Value: WordBool); safecall;
    procedure Set_AutoSize(Value: WordBool); safecall;
    procedure Set_AxBorderStyle(Value: TxActiveFormBorderStyle); safecall;
    procedure Set_Caption(const Value: WideString); safecall;
    procedure Set_Color(Value: OLE_COLOR); safecall;
    procedure Set_DoubleBuffered(Value: WordBool); safecall;
    procedure Set_DropTarget(Value: WordBool); safecall;
    procedure Set_Enabled(Value: WordBool); safecall;
    procedure Set_Font(const Value: IFontDisp); safecall;
    procedure Set_HelpFile(const Value: WideString); safecall;
    procedure Set_KeyPreview(Value: WordBool); safecall;
    procedure Set_PixelsPerInch(Value: Integer); safecall;
    procedure Set_PrintScale(Value: TxPrintScale); safecall;
    procedure Set_Scaled(Value: WordBool); safecall;
    procedure Set_ScreenSnap(Value: WordBool); safecall;
    procedure Set_SnapBuffer(Value: Integer); safecall;
    procedure Set_Visible(Value: WordBool); safecall;
    function Get_Money: Single; safecall;
    procedure Set_Money(Value: Single); safecall;
  public
    { Public declarations }
    procedure Initialize; override;
  end;

implementation

uses ComObj, ComServ, About1;

{$R *.DFM}

{ TTChMoney }

procedure TTChMoney.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
begin
  { Define property pages here.  Property pages are defined by calling
    DefinePropertyPage with the class id of the page.  For example,
      DefinePropertyPage(Class_TChMoneyPage); }
end;

procedure TTChMoney.EventSinkChanged(const EventSink: IUnknown);
begin
  FEvents := EventSink as ITChMoneyEvents;
  inherited EventSinkChanged(EventSink);
end;

procedure TTChMoney.Initialize;
begin
  inherited Initialize;
  OnActivate := ActivateEvent;
  OnClick := ClickEvent;
  OnCreate := CreateEvent;
  OnDblClick := DblClickEvent;
  OnDeactivate := DeactivateEvent;
  OnDestroy := DestroyEvent;
  OnKeyPress := KeyPressEvent;
  OnPaint := PaintEvent;
end;

function TTChMoney.Get_Active: WordBool;
begin
  Result := Active;
end;

function TTChMoney.Get_AlignDisabled: WordBool;
begin
  Result := AlignDisabled;
end;

function TTChMoney.Get_AutoScroll: WordBool;
begin
  Result := AutoScroll;
end;

function TTChMoney.Get_AutoSize: WordBool;
begin
  Result := AutoSize;
end;

function TTChMoney.Get_AxBorderStyle: TxActiveFormBorderStyle;
begin
  Result := Ord(AxBorderStyle);
end;

function TTChMoney.Get_Caption: WideString;
begin
  Result := WideString(Caption);
end;

function TTChMoney.Get_Color: OLE_COLOR;
begin
  Result := OLE_COLOR(Color);
end;

function TTChMoney.Get_DoubleBuffered: WordBool;
begin
  Result := DoubleBuffered;
end;

function TTChMoney.Get_DropTarget: WordBool;
begin
  Result := DropTarget;
end;

function TTChMoney.Get_Enabled: WordBool;
begin
  Result := Enabled;
end;

function TTChMoney.Get_Font: IFontDisp;
begin
  GetOleFont(Font, Result);
end;

function TTChMoney.Get_HelpFile: WideString;
begin
  Result := WideString(HelpFile);
end;

function TTChMoney.Get_KeyPreview: WordBool;
begin
  Result := KeyPreview;
end;

function TTChMoney.Get_PixelsPerInch: Integer;
begin
  Result := PixelsPerInch;
end;

function TTChMoney.Get_PrintScale: TxPrintScale;
begin
  Result := Ord(PrintScale);
end;

function TTChMoney.Get_Scaled: WordBool;
begin
  Result := Scaled;
end;

function TTChMoney.Get_ScreenSnap: WordBool;
begin
  Result := ScreenSnap;
end;

function TTChMoney.Get_SnapBuffer: Integer;
begin
  Result := SnapBuffer;
end;

function TTChMoney.Get_Visible: WordBool;
begin
  Result := Visible;
end;

function TTChMoney.Get_VisibleDockClientCount: Integer;
begin
  Result := VisibleDockClientCount;
end;

procedure TTChMoney._Set_Font(var Value: IFontDisp);
begin
  SetOleFont(Font, Value);
end;

procedure TTChMoney.AboutBox;
begin
  ShowTChMoneyAbout;
end;

procedure TTChMoney.ActivateEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnActivate;
end;

procedure TTChMoney.ClickEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnClick;
end;

procedure TTChMoney.CreateEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnCreate;
end;

procedure TTChMoney.DblClickEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnDblClick;
end;

procedure TTChMoney.DeactivateEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnDeactivate;
end;

procedure TTChMoney.DestroyEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnDestroy;
end;

procedure TTChMoney.KeyPressEvent(Sender: TObject; var Key: Char);
var
  TempKey: Smallint;
begin
  TempKey := Smallint(Key);
  if FEvents <> nil then FEvents.OnKeyPress(TempKey);
  Key := Char(TempKey);
end;

procedure TTChMoney.PaintEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnPaint;
end;

procedure TTChMoney.Set_AutoScroll(Value: WordBool);
begin
  AutoScroll := Value;
end;

procedure TTChMoney.Set_AutoSize(Value: WordBool);
begin
  AutoSize := Value;
end;

procedure TTChMoney.Set_AxBorderStyle(Value: TxActiveFormBorderStyle);
begin
  AxBorderStyle := TActiveFormBorderStyle(Value);
end;

procedure TTChMoney.Set_Caption(const Value: WideString);
begin
  Caption := TCaption(Value);
end;

procedure TTChMoney.Set_Color(Value: OLE_COLOR);
begin
  Color := TColor(Value);
end;

procedure TTChMoney.Set_DoubleBuffered(Value: WordBool);
begin
  DoubleBuffered := Value;
end;

procedure TTChMoney.Set_DropTarget(Value: WordBool);
begin
  DropTarget := Value;
end;

procedure TTChMoney.Set_Enabled(Value: WordBool);
begin
  Enabled := Value;
end;

procedure TTChMoney.Set_Font(const Value: IFontDisp);
begin
  SetOleFont(Font, Value);
end;

procedure TTChMoney.Set_HelpFile(const Value: WideString);
begin
  HelpFile := String(Value);
end;

procedure TTChMoney.Set_KeyPreview(Value: WordBool);
begin
  KeyPreview := Value;
end;

procedure TTChMoney.Set_PixelsPerInch(Value: Integer);
begin
  PixelsPerInch := Value;
end;

procedure TTChMoney.Set_PrintScale(Value: TxPrintScale);
begin
  PrintScale := TPrintScale(Value);
end;

procedure TTChMoney.Set_Scaled(Value: WordBool);
begin
  Scaled := Value;
end;

procedure TTChMoney.Set_ScreenSnap(Value: WordBool);
begin
  ScreenSnap := Value;
end;

procedure TTChMoney.Set_SnapBuffer(Value: Integer);
begin
  SnapBuffer := Value;
end;

procedure TTChMoney.Set_Visible(Value: WordBool);
begin
  Visible := Value;
end;

function TTChMoney.Get_Money: Single;
begin
  result:=Fmoney;
end;

procedure TTChMoney.Set_Money(Value: Single);
begin
  FMoney:=value;
  self.GetResult(floattostr(Fmoney));
end;

procedure TTChMoney.AddBit(i: integer; Save: string);
begin
 case i of
   -2:
        begin
           self.LblFen.Caption:=self.GetChinaNumber(strtoint(save));
           self.LblNo_2.Caption:=save;
        end;
   -1:
        begin
           self.Lbljiao.Caption:=self.GetChinaNumber(strtoint(save));
           self.LblNo_1.Caption:='.'+save;
        end;
   1:
        begin
             if self.LblShiXiao.Caption='\' then
                self.LblShiXiao.Caption:='￥';

              if self.LblNo8.Caption='' then
                self.LblNo8.Caption:='￥';

             self.LblYuan.Caption:=self.GetChinaNumber(strtoint(save));
             self.lblNo9.Caption:=save;
        end;
   2:
        begin
             if self.LblBaiXiao.Caption='\' then
                self.LblBaiXiao.Caption:='￥';
             if self.LblNo7.Caption='' then
                self.LblNo7.Caption:='￥';
             self.LblShiXiao.Caption:=self.GetChinaNumber(strtoint(save));
             self.LblNo8.Caption:=save;
        end;
   3:
        begin
             if self.LblQianXiao.Caption='\' then
                self.LblQianXiao.Caption:='￥';
             if self.LblNo6.Caption='' then
                self.LblNo6.Caption:='￥';
             self.LblBaiXiao.Caption:=self.GetChinaNumber(strtoint(save));
             self.LblNo7.Caption:=save;

        end;
   4:
        begin
             if self.LblWan.Caption='\' then
                self.LblWan.Caption:='￥';
             if self.LblNo5.Caption='' then
                self.LblNo5.Caption:='￥';
             self.LblQianXiao.Caption:=self.GetChinaNumber(strtoint(save));
             self.lblNo6.Caption:=save;
        end;
   5:
        begin
             if self.LblShi.Caption='\' then
                self.LblShi.Caption:='￥';
             if self.lblNo4.Caption='' then
                self.lblNo4.Caption:='￥';
             self.LblWan.Caption:=self.GetChinaNumber(strtoint(save));
             self.LblNo5.Caption:=save;
        end;
   6:
        begin
             if self.LblBai.Caption='\' then
                self.LblBai.Caption:='￥';
             if self.lblNo3.Caption='' then
                self.lblNo3.Caption:='￥';
              self.LblShi.Caption:=self.GetChinaNumber(strtoint(save));
              self.LblNo4.Caption:=save;
        end;
   7:
        begin
             if self.Lblqian.Caption='\' then
                self.Lblqian.Caption:='￥';
             if self.lblNo2.Caption='' then
                self.lblNo2.Caption:='￥';
              self.LblBai.Caption:=self.GetChinaNumber(strtoint(save));
              self.LblNo3.Caption:=save;
        end;
   8:
        begin
             if self.LblWan.Caption='\' then
                self.LblWan.Caption:='￥';
             if lblNo1.Caption='' then
                 self.LblNo1.Caption:='￥';

              self.Lblqian.Caption:=self.GetChinaNumber(strtoint(save));
              self.LblNo2.Caption:=save; 
        end;
   9:
        begin
             self.LblYi.Caption:='￥'+self.GetChinaNumber(strtoint(save));
             self.LblNo1.Caption:='￥'+save;
        end;
 end;
end;

function TTChMoney.GetChinaNumber(s: integer): string;
begin
 case s of
    0: result:='零';
    1: result:='壹';
    2: result:='贰';
    3: result:='叁';
    4: result:='肆';
    5: result:='伍';
    6: result:='陆';
    7: result:='柒';
    8: result:='捌';
    9: result:='玫';
  end;
end;

procedure TTChMoney.GetResult(r: string);
var
  i:integer;
  s1,s2:string;
begin
  self.init;//初始化.
  i:=pos('.',r);
  if i=0 then
     begin
        for i:=1 to length(r) do
            self.AddBit(length(r)-i+1,r[i]);
     end
  else
     begin
       s1:=copy(r,1,i-1);
       s2:=copy(r,i+1,length(r));
       for i:=1 to length(s1) do
            self.AddBit(length(s1)-i+1,s1[i]);
       if length(s2)<2 then
           s2:=s2+'00';
       self.AddBit(-1,s2[1]);
       self.AddBit(-2,s2[2]);
    end;

end;

procedure TTChMoney.init;
begin
self.LblFen.Caption:='\';
self.Lbljiao.Caption:='\';
self.LblYuan.Caption:='\';
self.LblShiXiao.Caption:='\';
self.LblBaiXiao.Caption:='\';
self.LblQianXiao.Caption:='\';
self.LblWan.Caption:='\';
self.LblShi.Caption:='\';
self.LblBai.Caption:='\';
self.Lblqian.Caption:='\';
self.LblWan.Caption:='\';
self.LblYi.Caption:='\';
self.LblNo_1.Caption:='';
self.LblNo_2.Caption:='';
self.LblNo1.Caption:='';
self.LblNo2.Caption:='';
self.LblNo3.Caption:='';
self.LblNo4.Caption:='';
self.LblNo5.Caption:='';
self.LblNo6.Caption:='';
self.LblNo7.Caption:='';
self.LblNo8.Caption:='';
self.LblNo9.Caption:='';
end;

initialization
  TActiveFormFactory.Create(
    ComServer,
    TActiveFormControl,
    TTChMoney,
    Class_TChMoney,
    1,
    '{DE56E7A5-8D41-4277-9561-484B90841C14}',
    OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
    tmApartment);
end.