function.pas

功能包中的大部分功能模块为本人自己所写。。部分收录我的网友的作品及网上比较精典的程序段。

      Procedure SetTitleNoActiveColor(Value:TColor);//设置Title mouseleave是的颜色
    //constructor Create(AOwner: TComponent);
  published
      property WinRectColor:TColor read FWinRectColor write SetWinRectColor;
      property WinRectLineWidth:integer read FWinRectLineWidth  write setWinRectLineWidth;
      property Caption:string read FCaption write SetCaption;
      property TitleActiveColor:TColor read FTitleActiveColor write SetTitleActiveColor;
      property TitleActiveFontColor:TColor Read FTitleActiveFontColor write SetTitleActiveFontColor;
      property TitleNoActiveColor:TColor read FTitleNoActiveColor write SetTitleNoActiveColor;
      property AutoBringTop:Boolean read FAutoBringTop write setAutoBringTop;//鼠标移入时自动窗体提前
      property OnMouseDown:TMyMouseEvent read FMouseDown write FMouseDown;
      property OnMouseUp:TMyMouseEvent read FMouseUp write FMouseUp;
      property OnMouseMove:TMouseMoveEvent read FMouseMove write FMouseMove;
      property OnClick:TNotifyEvent read FClick write FClick;
      Property OnMouseLeave:TNotifyEvent read FMouseLeave write FMouseLeave;
      Property OnMouseEnter:TNotifyEvent read FMouseEnter write FMouseEnter;
      property OnClose:TNotifyEvent read FCLose write FClose;
      property OnCanResize;
  //    property OnMouseDown:TmouseEvent read FMouseDown write FMouseDown;
  end;
//==============================================================================
// TFlatButton
//2004-3-29 lijinhao 23:06 (睡觉前突然想到。。。。哈哈^^)
//只有边框线的那种拉，呵呵决定从panel进行继承
//==============================================================================
  TFlatButton = class(TPanel)
  private
     FMouseEnter,FMouseLeave:TNotifyEvent;
     FLineInColor,FLineOutColor:TColor;
     FLineWidth:integer;
    procedure SetLineInColor(const Value: TColor);
    procedure SetLineOutColor(const Value: TColor);
    procedure SetLineWidth(const Value: integer);
  protected
     {code}
  public
       procedure WMMouseEnter(var Message:TMessage);Message CM_MouseEnter;
       procedure WMMouseLeave(var Message:TMessage);Message CM_MouseLeave;
    constructor Create(AOwner: TComponent); override;
     procedure Paint;override;
   // destructor Destroy; override;
  published
       //设置hot时的外框颜色
      property LineWidth:integer read FLineWidth write SetLineWidth;
      property LineInColor:TColor read FLineInColor Write SetLineInColor;
      property LineOutColor:TColor read FLineOutColor write SetLineOutColor;
      Property OnMouseLeave:TNotifyEvent read FMouseLeave write FMouseLeave;
      Property OnMouseEnter:TNotifyEvent read FMouseEnter write FMouseEnter;
  end;
{ TSwithButton }
//==============================================================================
// 2004-4-16
//对原有的button进行了一点改进
//==============================================================================
  FOnClick=procedure(sender:TObject;SwithFlag:boolean) of object;
  TSwithButton = class(TBitBtn)
  private
    FCaptionSwith: string;
    PCaption:string;//公共caption名
    FSwithFlag:Boolean;
    FOnClick: FOnClick;
  protected

  public
    procedure Click; override;
    constructor Create(AOwner: TComponent); override;
   // destructor Destroy; override;
  published
    property CaptionSwith:string read FCaptionSwith  write FCaptionSwith;
    property OnClick:FOnClick read FOnClick write FOnClick;
  end;


//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
procedure Register;
procedure DoBleep(Freq:Word; MSecs : LongInt); //DoBeep用户可调用过程头
//-----------
Var
  SysWinNT : Boolean; //DoBeep用于标识操作系统
  SYSHintExDraw:Boolean;
  Fn:Tfun;
implementation
//  uses BleepInt;
{$R MyFun.dcr}
{$R myRes.res}
{-------------------------------------------------------------------------------}
{-------------------------------------------------------------------------------}
{                                                                               }
{                                                                               }
{                     主程序开始                                                }
{                                                                               }
{                                                                               }
{-------------------------------------------------------------------------------}
{-------------------------------------------------------------------------------}
procedure Register;
begin
  registerComponents('MyFunction',[TFun,TvirtualKeyBoard,TExChart,TExEdit,TMyForm,TFlatButton,TSwithButton])
end;
//______________________________________________________________________________
//  DoBeep处理函数..摘自他人，作者未知
//感觉很棒就应用过来用了。HOHO....
//  利用写端口直接发声
Procedure AsmShutUp;
Begin
  Asm
    In AL, $61
    And AL, $FC
    Out $61, AL
  End;
End;

Procedure AsmBeep (Freq : Word);
Label
  Skip;
Begin
  Asm
        Push BX
        In AL, $61
        Mov BL, AL
        And AL, 3
        Jne Skip
        Mov AL, BL
        Or AL, 3
        Out $61, AL
        Mov AL, $B6
        Out $43, AL
  Skip: Mov AX, Freq
        Out $42, AL
        Mov AL, AH
        Out $42, AL
        Pop BX
  End;
End;

Procedure HardBleep(Freq : Word; MSecs : LongInt);
Const
  HiValue =50000;
Var
  iCurrTickCount, iFirstTickCount : DWord;
  iElapTime : LongInt;
Begin
  If (Freq>=20)And (Freq<=5000)Then Begin
    AsmBeep (Word (1193181 Div LongInt (Freq)));
    If MSecs>=0 Then Begin
      iFirstTickCount:=GetTickCount;
      Repeat
        If MSecs>1000 Then Application.ProcessMessages;
        iCurrTickCount:=GetTickCount;
        If iCurrTickCount<iFirstTickCount Then iElapTime:=HiValue-iFirstTickCount+iCurrTickCount
        Else iElapTime:=iCurrTickCount-iFirstTickCount;
      Until iElapTime>=MSecs;
      AsmShutUp;
    End;
  End;
End;

Procedure DoBleep(Freq:Word; MSecs:LongInt);
Begin
  If MSecs<-1 Then MSecs:=0;
  If SysWinNT Then
    Windows.Beep (Freq, MSecs)
  Else
    HardBleep (Freq, MSecs);
End;

Procedure ShutUp;
Begin
   If SysWinNT Then
     Windows.Beep (1, 0)
   Else
     AsmShutUp;
End;

Procedure InitSysType;
Var
  VersionInfo : TOSVersionInfo;
Begin
  VersionInfo.dwOSVersionInfoSize:=SizeOf (VersionInfo);
  GetVersionEx (VersionInfo);
  SysWinNt:=VersionInfo.dwPlatformID=VER_PLATFORM_WIN32_NT;
End;
//------------------------------------------------------------------------------
// DoBeep所有代码结束
//------------------------------------------------------------------------------
//______________________________________________________________________________


{------------------------------}
{-----十或十六进制转二进制-----}
{------------------------------}

Function  TFun.IntToBit(const source:word;const Bit:TBitType):string;
var
  str:string[16];
  bInt:byte;
  i:integer;
begin
    str:='';
    bInt:=0;
    for i:=1 to 16 do
    begin
       asm
         mov ax,word ptr[source]
         shl ax,1                (*最高位移至CF寄存器中*)
         mov word ptr[Source],ax (*保存移动后Source的值*)
         mov DL,0
         rcl DL,1                (*从CF中得到移出的最高位*)
         add DL,$30              (*加$30,将数值转化为ASCII码值*)
         mov byte ptr[bInt],DL
       end;
       str:=str+chr(bInt);
    end;
  case  bit of
   HighBit:str:=copy(str,1,8);  (*取高8位*)
   LowBit:str:=Copy(str,9,8);   (*取低8位*)
  end;
  result:=str;
end;
//________________________________________________________________________________

{--------------------------}
{-----二进制转到十进制-----}
{--------------------------}
Function TFun.BitToInt(sBin:string):integer;
var
  TempBin:string[16];
  bChar:byte;
  dwInt:word;
  i:integer;
begin
  TempBin:=StringOfchar('0',16-length(sBin))+sBin;(*不足16位，高位补零*)
  dwInt:=0;
  for i:=1 to 16  do
  begin
     bChar:=ord(TempBin[i]); //得到TempBin字串列表值
     asm
       mov al,byte ptr[bChar]
       sub al,$30 //ASCCII码-$30=对应的数字值
       RCR al,1   //移入CF寄存器
       RCl word ptr[dwInt],1 //dwInt右移
     end;
  end;
 result:=dwInt
end;
//________________________________________________________________________________

{--------------------------}
{-----十六进制转十进制-----}
{--------------------------}
Function TFun.HexToInt(sHex:string):integer;
var
 i:integer;
 dwRes:word;
 bInt:byte;
begin
   SHex:=StringOfchar('0',4-length(sHex))+sHex;(*不足4位十六进制，高位补零*)
   dwRes:=0;
   for i:=1 to 4 do
   begin
       case AnsiIndexStr(LowerCase(sHex[i]),['a','b','c','d','e','f']) of
          0:bInt:=10;
          1:bInt:=11;
          2:bInt:=12;
          3:bInt:=13;
          4:bInt:=14;
          5:bInt:=15;
       else
         bInt:=strToint(sHex[i])
       end;//end case
       asm
          xor ax,ax
          mov al,byte ptr[bInt]
          SHL word ptr[dwRes],4
          OR word ptr[dwRes],ax
       end
   end;//end for
   result:=dwRes
end;
//________________________________________________________________________________

{------------------------------}
{   (string)十六进制转二进制   }
{------------------------------}
Function TFun.HexToBit(sHex:string;Const Bit:TBitType):string;
begin
    result:=IntToBit(HexToInt(sHex),Bit)
end;
//________________________________________________________________________________


{------------------------------}
{   (string)二进制转十六进制   }
{------------------------------}
Function TFun.BitToHex(sBin:string;const Bit:integer):string;//2 to 16
begin
  result:=IntTohex(BitToint(sBin),bit)
end;
//________________________________________________________________________________

{----------------------------------------------}
{      将十六进制表示的十制制转为实际的十进制数}
{如: $12===>12  | $32===>32 ...                }
{    $24=38-2*6=24                             }
{----------------------------------------------}
Function TFun.HexBCDToint(sHexBCD:Byte):integer;
begin
    asm
      xor ax,ax
      mov al,byte ptr[sHexBCD]
      And al,$F0 (*得到高位*)
      shr al,4
      imul ax,6  (*得到6的倍数*)
      sub byte ptr[sHexBCD],al
    end;
    Result:=sHexBCD
End;
//------------------------------------------------------------------------------
{将int转为Hex值的BCD码}
function TFun.IntToBCD(Int:byte):word;
var
  iL,iH:integer;
begin
  iH:=integer(int div 10);
  iL:=int-iH*10;
  result:=ih*16+il;
end;
//________________________________________________________________________________

{--------------------}
{  托动无标题窗体    }
{--------------------}
//procedure TFun.DragWindow(handle:Thandle);
procedure TFun.MoveWindow(handle:Thandle);
begin
  ReleaseCapture;
  SendMessage(handle,WM_SYSCOMMAND,SC_MOVE or 2,0)
end;