DELPHI常用的函数库

最新推荐文章于 2024-05-29 08:43:15 发布

yangar9179

最新推荐文章于 2024-05-29 08:43:15 发布

阅读量1.7k

点赞数

文章标签： delphi integer string function constructor byte

http://www.smatrix.org/bbs/simple/index.php?t2328.html

unit myFun;
{-----------------------------------}
{ Create by 李金浩 }
{ QQ:67260745 }
{ 2004-3-21 }
{ 我的目标--共建理想常用函数库 }
{ install only for delphi7 }
{-----------------------------------}
interface
uses Windows, Messages, SysUtils,Variants,iniFiles, Classes, Controls,
Forms,Dialogs, StdCtrls,TeeProcs, TeEngine, Chart, ExtCtrls,StrUtils,
registry,Graphics,ComCtrls,Grids,Winsock,ShellApi,
DB,Buttons;
//comobj;
type
TBitType=(HighBit,LowBit,AllBit);

(*定义鼠标入键盘事件常量*)
TClickType=(leftDown,rightDown,midDown,
leftUp,rightUp,midUp,
leftDB,rightDB,midDB,
vkeyDown,vkeyUp,vKeyClick,
pageUp,PageDown);
//-------------------------------------
(*窗体大小常量*)
TWinRect=record
Top:integer;
Left:integer;
Width:integer;
Height:integer;
end;
//--IP设置常量--------
TNetValue=record
IpAddress:string;//IP地址
SubnetMask:string;//掩码
DefaultGateway:string;//默认网关
end;
//---------memo的返回常量-------
TmemoPos=record
LinePos:integer;//光标所在行号
CharPos:integer;//光标所在的字符位置
lineLenght:integer;//得到该行的字符长度
end;
//------------------
{===============================================================================}
{ TFun功能函数集合 }
{包含平时开发常用的函数及功能子程序. }
{===============================================================================}
TFun=class(TComponent)
// TFun=Class(TCustomControl)
private
{code}
myIniFile:TIniFile;
// procedure CMMouseEnter(var Msg:TMessage);message CM_MOUSEENTER;
// procedure CMMOUSELEAVE (var Msg:TMessage);message CM_MOUSELEAVE;
public
Function IntToBit(const source:word;const Bit:TBitType=AllBit):string; //10 to 16
function IntToHexEx(sInt:word;const Bit:integer=2):string;overload;
Function BitToInt(sBin:string):integer; //2 to 10
Function HexToInt(sHex:string):integer; //16 to 10
Function HexToBit(sHex:string;const Bit:TBitType=AllBit):string;//16 to 2
Function BitToHex(sBin:string;const Bit:integer=2):string;//2 to 16
{----------------------------------------------}
{ 将十六进制表示的十制制转为实际的十进制数}
{如: $12===>12 | $32===>32 ... }
{----------------------------------------------}
Function HexBCDToint(sHexBCD:Byte):integer;
Function IntToBCD(Int:Byte):word;
Function MinuteToTime(Minute:Double):TdateTime;overload;//分钟到标准时间的转换
Function MinuteToTime(Minute:Double;var DayCount:integer):TdateTime;overload;
//------------------------------------------------------------------------------
Function GetWeekOfChina(dDay:TdateTime):string;//得到星期
Function GetWeekOfNum(dDay:TdateTime):integer;
//------------------------------------------------------------------------------
Function IsStrAsNumber(NumStr:string):Bool;//判断字符串是不是有效数字在字符串
Function IsStrInOtherStr(mainStr,FindStr:string):Bool;//检测在一个字符串中是否包括另一个字符串
function IsCOMClassRegistered(GUID:TGUID):Boolean;//判断一个COM对像是否已注册
Function IsBDEInstalled:boolean;//查看ＢＤＥ是否安装
function GetPYIndexChar( hzchar:string):char;//得到汉字的首字母
Function Squ(X,Y:integer):integer;overload;//计算x的Y次方
Function Squ(X:Double;Y:integer):Double;overload;//计算x的Y次方
Function RandomNumByGUID:String;
//--------------系统功能------------
Function AppRunOnce:Boolean;//让程序只能运行一个实例
procedure AutoRunByReg(FileName:string='');//让程序自动运行
procedure DelAutoRunByReg(KeyName:string='');//删除一个自启动项
procedure MoveWindow(handle:Thandle);overload;//托动无标题窗体
Function GetAppPath(AddLastName:string=''):string;//得到程序的当前目录
Procedure ReMoveWinTitle(Form:Tform);//移去窗体的Title;
procedure BeepEx(Freq:Word;MSecs:LongInt); //DoBeep调用
procedure ClickStartMenu;//通过代码击活开始菜单
procedure OpenScreenSave;//打开屏幕保护
// procedure DelTree(DirName:String);//删除目录
procedure DeleteDir(SourcePath: String); //删除指定文件夹(含子文件夹),文件夹及其夹内文件可以具有只读或隐藏属性
procedure DelSelfApp;//程序在运行完后就删除自己
(*-----------------*)
procedure HideTaskBar(bHide:boolean=False);//显示或掩藏TaskBar
procedure DisplayOFFON(SW: boolean);//关闭和打开显示器
procedure HideDesktop(sw:Boolean=false);//显示和隐藏桌面
procedure HideDesktopAndTaskBar(sw:Boolean=false);//同时隐藏桌面和任务栏
procedure HideTrayNotify(sw:Boolean=false);//隐藏系统通知区域
procedure HideWinButton(sw:Boolean=false);//隐藏开始按钮
procedure HideQuickLaunchBar(sw:Boolean=false);//隐藏快速启动按钮栏
// procedure HideAppInTastWin(sw:Boolean=False);//使程序在任务管理器中隐藏
procedure DisbleQuikKey(sw:boolean=false);//屏蔽ALT+F4和ALT+Ctrl+Del
Function GetTaskBarHeight:integer;//得到任务栏的高度
//------------------------------------------------------------------------------
function GetDesktopListViewHandle: THandle; { 得到桌面列表试图的句柄 }
procedure MinWinAll;//最小化所有的窗体
procedure CloseWinAll;//关闭所有窗体
procedure DrawWindowRect(handle: Thandle;wColor: Tcolor=clBlack;PenWidth:integer=1);//给窗体加个边框
Procedure SetParentWinDefFont(Sender:TObject;const defFont:Tfont=nil);//设置parent窗体的默认字体
{得到memo中光标所在的位置，行号，行长}
procedure GetMemoMousePos(m:Tmemo;var posValue:TmemoPos);overload;
procedure GetMemoMousePos(m:TRichEdit;var posValue:TmemoPos);overload;
//Memo翻页
procedure setScrollPos(MHandle:Thandle;const pos:TClickType=PageDown);overload;

//得到指定窗体的大小
procedure GetWinRect(const WinHandle:HWND;var winRect:TwinRect);
procedure TimeDelay(DT:Dword);//精确毫秒级延时
procedure SetIPaddress(SIP: TNetValue;const isAuto:boolean=false);//设定网络Ip地址
Function GetLocalIP:string;//得到本机的IP地址
Procedure OpenURL(URL:string);//打开1个web URL
//==============================================================================
// 这一部分的函数摘自其他作者处.姓名不详
//==============================================================================
function GetDisplayFrequency: Integer; //获取显示刷新率
function GetIdeSerialNumber: String; //获取第一个硬盘的序列号
function GetCPUSpeed: Double; //获取当前CPU速率
Function GetCPUID:string; //获取CPU ID
Function GetCPUVendor: string; //获取CPU 类型
Function GetFileLastAccessTime(sFileName:string):TDateTime; //获取文件最后访问日期和时间
Function GetFileCreateTime(const strFileName:string):TDateTime; //获取文件创建时间
Function GetFileModifyTime(const strFileName:string):TDateTime; //获取文件修改时间
Function GetDNSTOIP(DNSName:String):String; //把域名转化为IP地址
Function GetDNSName(IPAddress:String):String; //把IP地址转化为域名
//==============================================================================
// 摘用部分结束
//==============================================================================
//--------------------------------
// procedure GetNetConf
//----------INI文件操作集-----------
(*_读ini文件_*)
Function ReadIniFile(const FileName,Section, Ident:string; Default: string):string; overload;
Function ReadIniFile(const FileName,Section, Ident:string; Default: integer):integer; overload;
Function ReadIniFile(const FileName,Section, Ident:string; Default: Double):Double; overload;
Function ReadIniFile(const FileName,Section, Ident:string; Default: Boolean):Boolean; overload;
Function ReadIniFile(const FileName,Section, Ident:string; Default: TdateTime):TdateTime; overload;
(*_写INI文件_*)
procedure WriteIniFile(const FileName,Section, Ident:string; Value:string);overload;
procedure WriteIniFile(const FileName,Section, Ident:string; Value:integer);overload;
procedure WriteIniFile(const FileName,Section, Ident:string; Value:Double);overload;
procedure WriteIniFile(const FileName,Section, Ident:string; Value:Boolean);overload;
procedure WriteIniFile(const FileName,Section, Ident:string; Value:TdateTime);overload;
//--------------------------
(*模拟鼠标单击*)
procedure SendMouseClick(const WinHandle:HWND;const PosX,PosY:integer;const ClickFlag:TClickType=vKeyclick);
(*模拟键盘按键*)
procedure SendKey(const WinHandle:HWND;const Vkey:word;const KeyClickFlag:TClickType=vkeyDown);
procedure SendComBoKey(const CtrlKey,FnKey:word);//如：发送ALT+F4
//-------------------------
{在指定的chart控件上画1条数直线，并返回mouse所在的index}
Function ChartMoveLine(Chart:Tobject;MousePos_X:Integer;LineColor:TColor=clRed):integer;
procedure DataToExcelCSV(SaveFileName:string;DataSet:TDataSet;ShowCompleteBoX:Boolean=True;GroupCount:integer=1);
(*---------声音DoBeep发声----------*)

// procedure Destroy;
{-------------------------------------------------------------------------------
作者: 不死鸟 ^^me 的好朋友提供的部分代码
日期: 2004.03.31
-------------------------------------------------------------------------------}
//将数据转为Excel文件，TDataSet中visible为False的字段不加入
// function DataToExcel(myExcelName: String; myDataSet: TDataSet): Boolean;
function ToBigRMB(RMB: string): string; //小写金额转大写
function IsRightDate(mInputDate:String):Boolean;//输入的日期是否正确
//字符串简单加密、解密函数 key=1时为加密，0为解密,利用xor操作
function Decrypt(const s: string; key:Byte=1): string;
function RightCopy(S: string; Index,count:Integer): string; //从右第Index位复制Count个字符
//----------------------------------------------------------------------------
procedure SetHintDraw(Flag:boolean=True);
constructor Create(AOwner: TComponent); override;
protected
{Code}
Published
{code}
end;
//_______________________________________________
{===============================================================================}
{ 带图标的提示栏 }
{ THintWindow类重载 }
{===============================================================================}
TIconHintX = class(THintWindow)
private
FActivating: Boolean;
FLastActive: Cardinal;
protected
procedure Paint;override;
public
procedure ActivateHint(Rect: TRect; const AHint: string);override;
// function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
end;
//______________________________________________________________________________
{===============================================================================}
{ TvirtualKeyBoard }
{工控触摸屏中常要输入数字和字符,于是利用TstringGrid,写了个虚拟键盘 }
{功能很有限,只是为了本人在工控系统中方便的使用,开发的 }
{要做到每个对象的输入,你可以在主form中利用wm_Lbuttondown来得到除自己外的对象句柄
来实现多对象输入！ }
{===============================================================================}
TVkeyDown=Procedure(Sender:TObject;KeyChar:String)of object;
TvirtualKeyBoard = class(TStringGrid)
private
FSendHandle:TWinControl;
FVkeyDown:TVkeyDown;
procedure SetSendHandle(Control:TWinControl);
{code}
protected

public
constructor Create(AOwner: TComponent); override;
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;AState: TGridDrawState);override;
function SelectCell(ACol, ARow: Longint): Boolean;override;
// destructor Destroy; override;
published
(*选择虚拟键盘的按盘发送对像，在Objecet Inspector中选择*)
property SendKeyControl:TWinControl read FSendHandle write SetSendHandle;
property OnSelectCell:TVkeyDown read FVkeyDown write FVkeyDown;
end;
//________________________________________________________________________________
{===============================================================================}
{ TExChart 2004-3-25 lijinhao }
{带有鼠标Y轴，绘线功能的Chart空件,自动获得Yvalue, }
{可以通过[YLableDraw]来设置将Yvalue显示在chart的左上角 }
{同时YLableCaption,和YLableUnit来分别设置名称和单位 }
{同样本人重写了OnMounseMove处理过程,在onMouseMove过程中也可以很方便的得到Yvalue }
{和Xindex这些原chart组件所没有的 }
{===============================================================================}
TChartYIndex=procedure(sender:TObject;XIndex,X,Y:integer;YValue:Double) of object;
TExChart = class(TChart)
private
FDrawMouseLineFlag:Boolean;
FDrawMouseLineColor:TColor;
FYLableCaption,FYLableUnit:String;//要显示Y的caption,和单位
FChartYIndex:TChartYIndex;
FYLableDraw:boolean;
procedure DrawMouseLine(Var Message:Tmessage);message WM_MouseMove;
procedure SetDrawMouseLineColor(Color:TColor);//设置mouseLine的颜色
procedure SetDrawMouseLineFlag(Flag:Boolean);//设置是否显示mouseline
procedure SetYLableCaption(caption:String);//设置Ylable名称
procedure SetYLableUnit(UnitValue:String);//设置Ylable单位
procedure SetYLableDraw(Flag:boolean);//设定YLable是否显示
protected
{code}
public
constructor Create(AOwner: TComponent); override;
// destructor Destroy; override;
published
property DrawMouseLineFlag:Boolean read FDrawMouseLineFlag write SetDrawMouseLineFlag;
property DrawMouseLineColor:TColor read FDrawMouseLineColor write SetDrawMouseLineColor;
property YLableCaption:String read FYLableCaption write SetYLableCaption;
property YLableUnit:String read FYLableUnit write SetYLableUnit;
property YLableDraw:Boolean read FYLableDraw write SetYLableDraw;
property OnMouseMove:TChartYIndex read FChartYIndex write FChartYIndex;
end;
{==============================================================================}
// TExEdit
//对原有的LableEdit上加入了OnlyInputNumber选项来控制只可以输入数字
{==============================================================================}
{ TExEdit }
TKeyDown=procedure(sender:Tobject;Key:Word) of object;
TExEdit = class(TLabeledEdit)
private
FOnlyInputNumber:Boolean;
FKeyDown:TKeyDown;
FCaption: string;
procedure WMKeyDown(Var Message:Tmessage);message WM_KeyUP;
procedure SetCaption(const Value: string);
protected
procedure SetOnlyInputNumber(Flag:Boolean);
public
// destructor Destroy; override;
constructor Create(AOwner: TComponent); override;
published
Property OnlyInputNumber:Boolean read FOnlyInputNumber write SetOnlyInputNumber;
property OnKeyDown:TKeyDown read FkeyDown write FkeyDown;
property Caption:string read FCaption write SetCaption;
end;
//======================TMyForm========================================================
// TMyForm modify by Panel Component
// lijinhao 2004-3-28
//利用panel。派生实现了1个模拟窗体。
//==============================================================================
TSizeFlag=(SZNil,SZLeft,SZRight,SZTop,SZBottom,
SZLeftTop,SZRightTop,
SZLeftBottom,SZRightBottom);
TMyMouseEvent=procedure(sender:TObject;MouseButton:TMouseButton;X,Y:integer)of Object;
TMyForm = class(TPanel)
private
FWinRectColor:TColor;
FWinRectLineWidth:integer;
FSizeFlag:TSizeFlag;
FTitleActiveColor:TColor;
FTitleActiveFontColor:TColor;
FTitleNoActiveColor:TColor;
FAutoBringTop:Boolean;
FCaption:string;
//---------------
FMouseDown,FMouseUp:TMyMouseEvent;
FMouseMove:TMouseMoveEvent;
FClose:TNotifyEvent;
//--------------
SizeFlag:boolean;
TempTitleColor:Tcolor;
FClick,FMouseEnter,FMouseLeave:TNotifyEvent;
// FMouseDown:TmouseEvent;
procedure WMLBUTTONDBLCLK(var message:TMessage);Message WM_LBUTTONDBLCLK;
procedure WMMouseMove(Var message:Tmessage);Message WM_MOUSEMOVE;
procedure WMLMouseDown(Var message:Tmessage);Message WM_LBUTTONDOWN;
procedure WMLMouseUp(Var message:Tmessage);Message WM_LBUTTONUP;
procedure WMRMouseDown(Var message:Tmessage);Message WM_RBUTTONDOWN;
procedure WMRMouseUp(Var message:Tmessage);Message WM_RBUTTONUP;
//----------
procedure WMMouseEnter(var Message:TMessage);Message CM_MouseEnter;
procedure WMMouseLeave(var Message:TMessage);Message CM_MouseLeave;
procedure setAutoBringTop(const Value: Boolean);
// procedure WMLMouseUp(Var message:TMessage);Message WM_LButtonUp;
protected
procedure DrawTitleButton;
public
constructor Create(AOwner: TComponent); override;
//destructor Destroy; override;
procedure Paint;override;
procedure SetWinRectColor(color:TColor);//设定窗体的边框颜色
Procedure SetWinRectLineWidth(Lwidth:integer);设定窗体的边框的粗度
procedure SetCaption(str:string);
procedure SetTitleActiveColor(color:TCOlor);//设置Title颜色
Procedure SetTitleActiveFontColor(Color:TColor);//设置Title字体颜色
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;
//________________________________________________________________________________

{-------------------------------}
{ 得到程序的当前目录 }
{并将exeName与得到的path合成返回}
{-------------------------------}
Function TFun.GetAppPath(AddLastName:string):string;
begin
//默认为application.exename
result:=ExTractFilePath(application.ExeName)+AddLastName;
end;
//________________________________________________________________________________

{----------------------}
{ 显示或掩藏TaskBar }
{----------------------}
procedure TFun.HideTaskBar(bHide:boolean=False);
var
TaskBarHWN:integer;
begin
TaskBarHWN:=Findwindow('Shell_TrayWnd',nil);
if not bhide then
SetWindowPos(TaskBarHWN,0,0,0,0,0,SWP_HIDEWINDOW)
else
SetWindowPos(TaskBarHWN,0,0,0,0,0,SWP_SHOWWINDOW)
end;
//________________________________________________________________________________
{-----------------------------}
{ 模拟鼠标click }
{-----------------------------}
procedure TFun.SendMouseClick(const WinHandle: HWND;
const PosX,PosY: integer;
const ClickFlag:TClickType);
begin
case ClickFlag of
leftDown:Sendmessage(WinHandle,WM_LButtonDown,0,PosX+PosY*65536);//左键按下
rightDown:Sendmessage(WinHandle,WM_RButtonDown,0,PosX+PosY*65536);//右键按下
midDown:Sendmessage(WinHandle,WM_MBUTTONDOWN,0,PosX+PosY*65536);//中间键按下
//-----
leftUp:Sendmessage(WinHandle,WM_LButtonUp,0,PosX+PosY*65536);//左键放开
rightUp:Sendmessage(WinHandle,WM_RButtonUp,0,PosX+PosY*65536);//右键放开
midUp:Sendmessage(WinHandle,WM_MButtonUp,0,PosX+PosY*65536);//中键放开
//-----
leftDB:Sendmessage(WinHandle,WM_LBUTTONDBLCLK,0,PosX+PosY*65536);//左键双击
rightDB:Sendmessage(WinHandle,WM_RBUTTONDBLCLK,0,PosX+PosY*65536);//左键双击
midDB:Sendmessage(WinHandle,WM_MBUTTONDBLCLK,0,PosX+PosY*65536);//中键双击
end;
end;
//________________________________________________________________________________
{-------------------}
{ *模拟键盘事件* }
{-------------------}
procedure TFun.SendKey(const WinHandle: HWND; const Vkey: word;
const KeyClickFlag: TClickType);
begin
case KeyClickFlag of
vkeyDown:postMessage(WinHandle,WM_KEYDOWN,vkey,MapVirtualKey(Vkey,0));
vkeyUp:postMessage(WinHandle,WM_KEYUP,vkey,MapVirtualKey(Vkey,0));
vkeyClick:
begin
postMessage(WinHandle,WM_KEYDOWN,vkey,MapVirtualKey(Vkey,0));
postMessage(WinHandle,WM_KEYUP,vkey,MapVirtualKey(Vkey,0));
end;
end;
end;
//________________________________________________________________________________

{----------------------------}
{ 得到指定窗体的大小 }
{得到的坐标为全屏坐标 }
{----------------------------}
procedure TFun.GetWinRect(const WinHandle: HWND; var winRect: TwinRect);
var
R:TRect;
begin
GetWindowRect(winHandle,R);
winRect.Top:=R.Top;
winRect.Left:=R.Left;
winRect.Width:=R.Right-r.Left;
winRect.Height:=R.Bottom-R.Top
end;
//________________________________________________________________________________
{-----------------------}
{ 分钟到标准时间的转换 }
{ mm===>hh:mm:ss }
{2004-3-30号修正 }
{-----------------------}
function TFun.MinuteToTime(Minute: Double): TdateTime;
var
ihh,imm,iss:integer;
begin
ihh:=Round(Minute/60-0.5);//得到时
imm:=round(Minute-ihh*60-0.5); //得到分
iss:=round((minute-ihh*60-imm)*100-0.5);//得到秒
//----------得到秒后再重算一次---------
imm:=imm+iss div 60;
if iss>60 then iss:=iss-60;
ihh:=ihh+imm div 60;
if ihh>12 then ihh:=ihh-12*round(ihh / 12-0.5);
result:=strTotime(format('%.2d:%.2d:%.2d',[ihh,imm,iss]))
end;
//______________________________________________________________________________
//--------------------------
//返回天数的MinuteToTime
//added 2004-3-30
//--------------------------
function TFun.MinuteToTime(Minute: Double;
var DayCount: integer): TdateTime;
var
ihh,imm,iss:integer;
begin
DayCount:=0;
ihh:=Round(Minute/60-0.5);//得到时
imm:=round(Minute-ihh*60-0.5); //得到分
iss:=round((minute-ihh*60-imm)*100-0.5);
imm:=imm+iss div 60;
if iss>=60 then iss:=iss-60;
ihh:=ihh+imm div 60;
if ihh>=24 then DayCount:=round(ihh/24);
if ihh>=12 then ihh:=ihh-12*round(ihh/12);
result:=strTotime(format('%.2d:%.2d:%.2d',[ihh,imm,iss]))
end;
//------------------------------------------------------------------------------
//
//------------------------------------------------------------------------------

{--------------}
{精确毫秒级延时}
{--------------}
procedure TFun.TimeDelay(DT: Dword);
var
TT:Dword;
begin
TT:=GetTickCount;
while getTickCount-TT<DT do
application.ProcessMessages;//防止死锁
end;
//______________________________________________________________________________

{-------------------}
{ 设定网络Ip地址 }
{-------------------}
procedure TFun.SetIPaddress(SIP: TNetValue;const isAuto:boolean);
var
reg:Tregistry;
begin
reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('/SYSTEM/ControlSet001/Services/{6CF72061-4BB8-47D6-96CD-76886198826A}/Parameters/Tcpip',true) then
begin
if not isAuto then
begin
reg.WriteString('IpAddress',sIP.IpAddress);
reg.WriteString('SubnetMask',sIP.SubnetMask);
reg.WriteString('DefaultGateway',sIP.DefaultGateway);
reg.WriteBool('EnableDHCP',false);
end else
begin
reg.WriteBool('EnableDHCP',true);
reg.WriteString('IpAddress','0.0.0.0');
end;
end;
reg.CloseKey;
reg.Free;
end;
//______________________________________________________________________________

{----------------------------------}
{得到memo的行号，当前位置，行长度等}
{----------------------------------}
procedure TFun.GetMemoMousePos(m: Tmemo;var posValue:TmemoPos);
begin
posValue.LinePos:=sendmessage(m.Handle,EM_LINEFROMCHAR,m.SelStart,0);//得到行号
posValue.CharPos:=sendmessage(m.Handle,EM_LINEINDEX,posValue.LinePos,0);//得到字符位置
posValue.lineLenght:=sendmessage(m.Handle,EM_LINELENGTH,posValue.CharPos,0);//得到长的长度
end;
{重载RichEdit对像处理}
procedure TFun.GetMemoMousePos(m:TRichEdit;var posValue:TmemoPos);
begin
posValue.LinePos:=sendmessage(m.Handle,EM_LINEFROMCHAR,m.SelStart,0);//得到行号
posValue.CharPos:=sendmessage(m.Handle,EM_LINEINDEX,posValue.LinePos,0);//得到字符位置
posValue.lineLenght:=sendmessage(m.Handle,EM_LINELENGTH,posValue.CharPos,0);//得到长的长度
end;
//______________________________________________________________________________
//Memo翻页
procedure TFun.setScrollPos(MHandle: Thandle; const pos: TClickType);
begin
if pos=pageDown then
SendMessage(MHandle,wm_Keydown,Vk_next,-1)
else
SendMessage(MHandle,wm_KeyUp,Vk_next,-1)
end;
//______________________________________________________________________________
{------------------------}
{ 打开和关闭显示器 }
{ for win9x }
{------------------------}
procedure TFun.DisplayOFFON(SW: boolean);
begin
if SW then
(*打开显示器*)
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,-1)
else
(*关闭显示器*)
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,0)
end;
//______________________________________________________________________________
{-------------------}
{ 显示和隐藏桌面 }
{-------------------}
procedure TFun.HideDesktop(sw: Boolean);
begin
if sw then
(*显示*)
showWindow(findwindow('Progman',nil),sw_Show)
else
(*隐藏*)
showWindow(findwindow('Progman',nil),sw_Hide)
end;
//______________________________________________________________________________
{-----------------------}
{ 同时隐藏桌面和任务栏 }
{-----------------------}
procedure TFun.HideDesktopAndTaskBar(sw: Boolean);
begin
HideTaskBar(SW);//关闭和打开显示器
HideDesktop(sw);//显示和隐藏桌面
end;
//______________________________________________________________________________

{屏蔽ALT+F4和ALT+Ctrl+Del}
{ 仅用于win9X }
procedure TFun.DisbleQuikKey(sw: boolean);
var
temp,iC:integer;
begin
if sw then iC:=0 else iC:=1;
//iC=1为屏蔽,0为恢复
SystemParametersInfo(Spi_screensaverrunning,iC,@temp,0);
end;
//______________________________________________________________________________
{---------------------------------}
{ 让程序只运行一次 }
{---------------------------------}
Function TFun.AppRunOnce:Boolean;
var
HW:Thandle;
sClassName,sTitle:string;
begin
sClassName:=application.ClassName;
sTitle:=application.Title;
application.Title:='F982D120-BA1E-4199-8FBD-F4EED2F6E8A7'; //更改当前app标题
HW:=findwindow(pchar(sClassName),pchar(sTitle));
(*如果发现已有实例在运行，则关闭自己*)
if HW<>0 then application.Terminate;
application.Title:=sTitle; //恢复app标题
result:=Hw<>0 //存在则返回true,无返回false
end;
//______________________________________________________________________________
{----------------------------}
{判断字符串是不是有效数字字符}
{----------------------------}
function TFun.IsStrAsNumber(NumStr:string):Bool;
var
i:integer;
begin
result:=True;
if not (Numstr[1] in ['1','2','3','4','5','6','7','8','9']) then
begin
{首位为0，或者是其他的非数字字符，则提前返回false}
result:=false;
exit
end;
//--------------
for i:=1 to length(NumStr) do
begin
if not (Numstr[i] in ['0','1','2','3','4','5','6','7','8','9']) then
begin
result:=false;
exit
end;
end;(* for i:=1 to length(NumStr) do*)
end;
//______________________________________________________________________________
{-----------------}
{ 如：发送ALT+F }
{-----------------}
procedure TFun.SendComBoKey(const CtrlKey, FnKey: word);
begin
keybd_event(CtrlKey, MapVirtualKey(CtrlKey, 0),0,0);
keybd_event(FnKey, MapVirtualKey(FnKey, 0),0,0);
keybd_event(FnKey, MapVirtualKey(FnKey, 0),KEYEVENTF_KEYUP,0);
keybd_event(CtrlKey, MapVirtualKey(CtrlKey, 0),KEYEVENTF_KEYUP,0);
end;
//______________________________________________________________________________
{------------------------}
{ 得到汉字的首字母 }
{------------------------}
function TFun.GetPYIndexChar( hzchar:string):char;
begin
case WORD(hzchar[1]) shl 8 + WORD(hzchar[2]) of
$B0A1..$B0C4 : result := 'A';
$B0C5..$B2C0 : result := 'B';
$B2C1..$B4ED : result := 'C';
$B4EE..$B6E9 : result := 'D';
$B6EA..$B7A1 : result := 'E';
$B7A2..$B8C0 : result := 'F';
$B8C1..$B9FD : result := 'G';
$B9FE..$BBF6 : result := 'H';
$BBF7..$BFA5 : result := 'J';
$BFA6..$C0AB : result := 'K';
$C0AC..$C2E7 : result := 'L';
$C2E8..$C4C2 : result := 'M';
$C4C3..$C5B5 : result := 'N';
$C5B6..$C5BD : result := 'O';
$C5BE..$C6D9 : result := 'P';
$C6DA..$C8BA : result := 'Q';
$C8BB..$C8F5 : result := 'R';
$C8F6..$CBF9 : result := 'S';
$CBFA..$CDD9 : result := 'T';
$CDDA..$CEF3 : result := 'W';
$CEF4..$D188 : result := 'X';
$D1B9..$D4D0 : result := 'Y';
$D4D1..$D7F9 : result := 'Z';
else
result := char(0);
end;
end;
//______________________________________________________________________________
{-------------------------}
{ 得到桌面列表试图的句柄 }
{-------------------------}
function TFun.GetDesktopListViewHandle: THandle;
var
S: String;
begin
Result := FindWindow('ProgMan', nil);
Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD);
SetLength(S, 40);
GetClassName(Result, PChar(S), 39);
if PChar(S) <> 'SysListView32' then Result := 0;
end;
//______________________________________________________________________________

{----------------TIconHintX------------------}
{ 重载ActivateHint，调整输出字符长度 }
{--------------------------------------------}
procedure TIconHintX.ActivateHint(Rect: TRect; const AHint: string);
type
TAnimationStyle = (atSlideNeg, atSlidePos, atBlend);
const
AnimationStyle: array[TAnimationStyle] of Integer = (AW_VER_NEGATIVE,
AW_VER_POSITIVE, AW_BLEND);
var
Animate: BOOL;
Style: TAnimationStyle;
pos:Tpoint;
begin
GetCursorPos(Pos);
FActivating := True;
try
Caption :=' '+AHint; (*前面价2个空格让图标可以正常显示*)
Inc(Rect.right,12);
Inc(Rect.Bottom,4);
UpdateBoundsRect(Rect);
if Rect.Top + Height > Screen.DesktopHeight then
Rect.Top := Screen.DesktopHeight - Height;
if Rect.Left + Width > Screen.DesktopWidth then
Rect.Left := Screen.DesktopWidth - Width;
if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;
if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;
SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,SWP_NOACTIVATE);
if (GetTickCount - FLastActive > 250) and (Length(AHint) < 100) and
Assigned(AnimateWindowProc) then
begin
SystemParametersInfo(SPI_GETTOOLTIPANIMATION, 0, @Animate, 0);
if Animate then
begin
SystemParametersInfo(SPI_GETTOOLTIPFADE, 0, @Animate, 0);
if Animate then
Style := atBlend
else
if Pos.Y > Rect.Top then
Style := atSlideNeg
else
Style := atSlidePos;
AnimateWindowProc(Handle, 100, AnimationStyle[Style] or AW_SLIDE);
end;
end;
ParentWindow := Application.Handle;
ShowWindow(Handle, SW_SHOWNOACTIVATE);
Invalidate;
finally
FLastActive := GetTickCount;
FActivating := False;
end;
end;
//______________________________________________________________________________
{function TIconHintX.CalcHintRect(MaxWidth: Integer; const AHint: string;
AData: Pointer): TRect;
var
Hicon:TBitmap;
begin
Hicon:=TBitmap.Create;
Hicon.LoadFromResourceName(Hinstance,'HICON');
//-----
Result := inherited CalcHintRect(MaxWidth,AHint, AData);
Result.Right := (Length(AHint) * 5) + Hicon.Width*4;
Result.Bottom := (Hicon.Height)+4;
Hicon.Free;
end; }
//______________________________________________________________________________

procedure TIconHintX.Paint;
var
Hicon:TBitmap;
R: TRect;
begin
inherited;
R := ClientRect;
Inc(R.Left, 20);
Inc(R.Top, 2);
//-------
Hicon:=TBitmap.Create;
Hicon.LoadFromResourceName(Hinstance,'HICON');
color:=$00EEFDF2;
Canvas.Draw(1,1,Hicon);
SendMessage(Handle, WM_NCPAINT, 0, 0); //画提示栏边框
Hicon.Free;
end;
//______________________________________________________________________________

{-------------------------------}
{ 设置parent窗体的字体 }
{-------------------------------}
procedure TFun.SetParentWinDefFont(Sender:TObject;const defFont: Tfont);
begin
if defFont=nil then
begin;
{设置默认}
TForm(Sender as TComponent).Font.Name:='宋体';
TForm(Sender as TComponent).Font.Size:=9;
TForm(Sender as TComponent).Font.Height:=-12;
TForm(Sender as TComponent).Font.Color:=clblack;
TForm(Sender as TComponent).Font.Charset:=GB2312_CHARSET
end else
(*用户定义*)
TForm(Sender as TComponent).Font:=defFont
end;
//______________________________________________________________________________

{---------------------------}
{ 计算x的Y次方 }
{---------------------------}
function TFun.Squ(X, Y: integer): integer;
var
i,sum:integer;
begin
sum:=1;
for i:=1 to Y do sum:=sum*X;
result:=sum
end;
{浮点型}
function TFun.Squ(X: Double; Y: integer): Double;
var
i:integer;
dsum:double;
begin
dsum:=1;
for i:=1 to Y do dsum:=dsum*X;
result:=dsum
end;
//______________________________________________________________________________

{-------------------------------------------------------}
{在指定的chart控件上画1条数直线，并返回mouse所在的index }
{处理鼠标在Chart里移动的过程，在最近的数据点上画一直线，}
{X表示是鼠标的X坐标位置，iValueIdx是回传的数据点索引号 }
{chart的index 从0开始的。。要注意 }
{-------------------------------------------------------}
Function TFun.ChartMoveLine(Chart:Tobject;MousePos_X:Integer;LineColor:TColor):integer;
Var
i,x:Integer;
iXPosition,iValueIdx,iValueCount:Integer;
dXValue : Double;
begin
x:=MousePos_X;
iValueIdx:=-1;
iValueCount:=TChart(Chart as TComponent).Series[0].count;
if iValueCount<>0 then
begin
dXValue := TChart(Chart as TComponent).Series[0].XScreenToValue(X);
if dXValue <= TChart(Chart as TComponent).Series[0].XValue[0] then
iValueIdx := 0
else if dXValue >= TChart(Chart as TComponent).Series[0].XValue[iValueCount-1] then
iValueIdx := iValueCount-1
else
for i:=1 to iValueCount-1 do
if (dXValue >= TChart(Chart as TComponent).Series[0].XValue[i-1]) and (dXValue <= TChart(Chart as TComponent).Series[0].XValue[i]) then
begin
if (dXValue-TChart(Chart as TComponent).Series[0].XValue[i-1])<(TChart(Chart as TComponent).Series[0].XValue[i]-dXValue) then
iValueIdx := i-1
else
iValueIdx := i;
break;
end;
dXValue := TChart(Chart as TComponent).Series[0].XValue[iValueIdx];
iXPosition := TChart(Chart as TComponent).BottomAxis.CalcXPosValue(dXValue);
TChart(Chart as TComponent).Repaint;
With TChart(Chart as TComponent).Canvas do
begin
Pen.Width:=1;
Pen.Style:=psSolid;
Pen.Color:=LineColor;
with TChart(Chart as TComponent) do
begin
MoveTo(iXposition,ChartRect.Top);
LineTo(iXPosition,ChartRect.Bottom );
end;//with TChart(Chart as TComponent) do
end;
end;// if iValueCount<>0 then
result:=iValueIdx;//返回mouse所在的chart上的index
end;
//_______________________________________________________________________________
{-------------------------}
{让程序开机时自动运行 }
{写注册表的run }
{-------------------------}
procedure TFun.AutoRunByReg(FileName:string);
var
reg:Tregistry;
fP:string;
begin
if FileName='' then fp:=application.Title;
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('/SOFTWARE/Microsoft/Windows/CurrentVersion/Run',true) then
begin
reg.WriteString(fp,application.exeName);
end;
reg.CloseKey;
reg.Free;
end;
//-------------------------------------------------------------------------------
//删除regKey===>Autorun
procedure TFun.DelAutoRunByReg(KeyName: string);
var
reg:Tregistry;
sKey:string;
begin
if KeyName='' then sKey:=application.Title;
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('/SOFTWARE/Microsoft/Windows/CurrentVersion/Run',false) then
begin
reg.DeleteValue(sKey)
end;
reg.CloseKey;
reg.Free;
end;
//______________________________________________________________________________
{------------------------}
{最小化系统所有的窗体 }
{------------------------}
procedure TFun.MinWinAll;
var
h:HWnd;
begin
h:=application.Handle;
while h > 0 do
begin
if isWindowVisible(h) then
postmessage(h,WM_SYSCOMMAND,SC_MINIMIZE,0);
h:=getnextwindow(h,GW_HWNDNEXT);
end;
end;
//______________________________________________________________________________

{---------------------}
{ 关闭所有窗体 }
{---------------------}
procedure TFun.CloseWinAll;
var
h:HWnd;
begin
h:=application.Handle;
while h > 0 do
begin
if isWindowVisible(h) and (H<>application.Handle)
and (H<>FindWindow('Progman', nil))
then postmessage(h,WM_Close,0,0);
h:=getnextwindow(h,GW_HWNDNEXT);
end;
end;
//_______________________________________________________________________________
{----------------------}
{给窗体加个边框 }
{----------------------}
procedure TFun.DrawWindowRect(handle: Thandle;wColor:Tcolor;PenWidth:integer);
var
dc : hDc;
Pen : hPen;
OldPen : hPen;
OldBrush : hBrush;
WinR:TwinRect;
begin
GetWinRect(handle,WinR);
dc := GetWindowDC(Handle);
Pen := CreatePen(PS_SOLID,PenWidth,wColor);
OldPen := SelectObject(dc,Pen);
OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, WinR.Width, WinR.Height);
SelectObject(dc, OldBrush);
SelectObject(dc, OldPen);
DeleteObject(Pen);
ReleaseDC(Handle,0);
end;
//_______________________________________________________________________________
{----------------------------------------------------}
{ InI文件操作函数集 }
{可利用fun1.GetAppPath('mytest.ini')得到完整的ini目录}
{----------------------------------------------------}
{------------read Integer------------}
function TFun.ReadIniFile(const FileName, Section, Ident: string;
Default: integer): integer;
begin
myIniFile:=TiniFile.Create(FileName);
result:=myIniFile.ReadInteger(Section,Ident,Default);
myIniFile.FreeInstance;
end;
{------------read string------------}
function TFun.ReadIniFile(const FileName, Section, Ident: string;
Default: string): string;
begin
myIniFile:=TiniFile.Create(FileName);
result:=myIniFile.ReadString(Section,Ident,Default);
myIniFile.FreeInstance;
end;
{------------read Boolean------------}
function TFun.ReadIniFile(const FileName, Section, Ident: string;
Default: Boolean): Boolean;
begin
myIniFile:=TiniFile.Create(FileName);
result:=myIniFile.ReadBool(Section,Ident,Default);
myIniFile.FreeInstance;
end;
{------------read Double------------}
function TFun.ReadIniFile(const FileName, Section, Ident: string;
Default: Double): Double;
begin
myIniFile:=TiniFile.Create(FileName);
result:=myIniFile.ReadFloat(Section,Ident,Default);
myIniFile.FreeInstance;
end;
{------------read DateTime-----------}
function TFun.ReadIniFile(const FileName, Section, Ident: string;
Default: TdateTime): TdateTime;
begin
myIniFile:=TiniFile.Create(FileName);
result:=myIniFile.ReadDateTime(Section,Ident,Default);
myIniFile.FreeInstance;
end;
//_________________________________________________________________________________
{------------Write Integer------------}
procedure TFun.WriteIniFile(const FileName, Section, Ident: string;
Value: integer);
begin
myIniFile:=TiniFile.Create(FileName);
myIniFile.WriteInteger(Section,Ident,Value);
myIniFile.FreeInstance;
end;
{------------Write String------------}
procedure TFun.WriteIniFile(const FileName, Section, Ident: string;
Value: string);
begin
myIniFile:=TiniFile.Create(FileName);
myIniFile.WriteString(Section,Ident,Value);
myIniFile.FreeInstance;
end;
{------------Write boolean------------}
procedure TFun.WriteIniFile(const FileName, Section, Ident: string;
Value: Boolean);
begin
myIniFile:=TiniFile.Create(FileName);
myIniFile.WriteBool(Section,Ident,Value);
myIniFile.FreeInstance;
end;
{------------Write Double------------}
procedure TFun.WriteIniFile(const FileName, Section, Ident: string;
Value: Double);
begin
myIniFile:=TiniFile.Create(FileName);
myIniFile.WriteFloat(Section,Ident,Value);
myIniFile.FreeInstance;
end;
{------------Write DateTime------------}
procedure TFun.WriteIniFile(const FileName, Section, Ident: string;
Value: TdateTime);
begin
myIniFile:=TiniFile.Create(FileName);
myIniFile.WriteDateTime(Section,Ident,Value);
myIniFile.FreeInstance;
end;
//______________________________________________________________________________
{procedure TFun.Destroy;
begin
inherited destroy;
end;}
//______________________________________________________________________________

{--------------------}
{得到日期对应的时间 }
{--------------------}
function TFun.GetWeekOfChina(dDay: TdateTime): string;
var
iwIndex:integer;
begin
iwIndex:=dayOfweek(dDay);
case iwIndex of
1:result:='星期天';
2:result:='星期一';
3:result:='星期二';
4:result:='星期三';
5:result:='星期四';
6:result:='星期五';
7:result:='星期六';
end;
end;
{--------------------------------------}
{星期一.....星期天: 1---7 }
{NND的外国人就喜欢用1表示星期天靠!不爽 }
{收以该位我们中国人习惯的1-7方式 }
{---------------------------------------}
function TFun.GetWeekOfNum(dDay: TdateTime): integer;
var
iwIndex:integer;
begin
iwIndex:=dayOfweek(dDay);
if iwIndex=1 then iwIndex:=7 else iwIndex:=iwIndex-1;
result:=iwIndex
end;
//________________________________________________________________________________________________________________________________________________________
{------------------------------------------------------}
{检测findStr是否in mainStr,如果存在则返回True,否则False}
{------------------------------------------------------}
function TFun.IsStrInOtherStr(mainStr,FindStr: string): Bool;
begin
if strPos(pAnsiChar(mainStr),pAnsichar(FindStr))=nil
then
result:=False
else
result:=True;
end;
//______________________________________________________________________________
{--------------------------------------}
{利用GUID得到一个永远不会重复的随机序列}
{--------------------------------------}
function TFun.RandomNumByGUID:string;
var
ID: TGUID;
begin
if CreateGuid(Id) =0 then
begin
result:= GUIDToString(Id);
end;
end;
//______________________________________________________________________________
{------------------------------}
{ 判断一个COM对像是否注册过 }
{------------------------------}
function TFun.IsCOMClassRegistered(GUID: TGUID): Boolean;
var
COMGUID:String;
begin
with TRegistry.Create do
try
COMGUID:=GUIDToString(GUID);
RootKey:=HKEY_CLASSES_ROOT;
Result := OpenKey('/CLSID/'+COMGUID,False);
finally
Free;
end;
end;
//______________________________________________________________________________
{-------------------------------------}
{ 移去窗体的Title }
{-------------------------------------}
procedure TFun.ReMoveWinTitle(Form:Tform);
begin
SetWindowLong(Form.Handle,GWL_STYLE,
GetWindowLong(Form.Handle,GWL_STYLE) and not WS_CAPTION);
Form.Height:=Form.ClientHeight;
end;
//______________________________________________________________________________
{-------------------------------}
{判断BDE是否安装过。 }
{已安装返回True,否则为false }
{-------------------------------}
function TFun.IsBDEInstalled: boolean;
var
reg:Tregistry;
s:string;
begin
s:='';
reg:=Tregistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE/Borland/Database Engine', False);
try
S:=reg.ReadString('CONFIGFILE01');
//BDE installed
finally
if S<>'' then result:=True else result:=False;
reg.CloseKey;
end;
end;
//______________________________________________________________________________
{系统小喇叭发声}
procedure TFun.BeepEx(Freq: Word; MSecs: Integer);
begin
DoBleep(Freq,MSecs); //DoBeep用户可调用过程头
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//==============================================================================
// 虚拟键盘，是由于本人从事数据采集系统的
// 工业电脑用的是触摸屏，写了这个，用这方便。呵呵。
//从TstrigGrid继承来的，，功能很有限，因为考虑到是用于6.5英寸的触摸屏上。
//没加其他标准的键盘功能。
//==============================================================================
{ TvirtualKeyBoard }
constructor TvirtualKeyBoard.Create(AOwner: TComponent);
const
KeyStr:array[0..2,0..13] of string=(('7','8','9','A','B','C','D','E','F','G','H','I','J','←'),
('4','5','6','','K','M','N','L','O','P','Q','R','','↙'),
('0','1','2','3','.','S','T','U','V','W','X','Y','Z',','));
var
i,j:integer;
begin
inherited Create(AOwner);
ScrollBars:=ssNone;
Height:=96;
Width:=438;
self.Show;
RowCount:=3;
ColCount:=14;
FixedCols:=0;
FixedRows:=0;
Ctl3D:=false;
DefaultColwidth:=30;
DefaultRowHeight:=30;
// ,10,[B],GB2312_CHARSET,clWindowText
// font.Style:=[fsBold];
font.Name:='宋体';
font.Size:=16;
font.Charset:=GB2312_CHARSET;
//-----------------
for i:=0 to RowCount-1 do
begin
for j:=0 to ColCount-1 do
begin
cells[j,i]:=KeyStr[i,j]
end;
end;
end;

fleshwound

2006-03-02 08:52

{-------重载DrawCell着色----------}
procedure TvirtualKeyBoard.DrawCell(ACol, ARow: Integer; ARect: TRect;
AState: TGridDrawState);
begin
inherited;

if (ACol<=2) or ((Arow=2) and (aCol in [13,3,4]))
or ((Arow=1) and (aCol in [12,13,3]))
or ((Arow=0) and (aCol in [13])) then
begin
canvas.Font.Color:=clwhite;
Canvas.Brush.Color:=clGray;
Canvas.FillRect(ARect);
end;
Canvas.TextRect(ARect, ARect.Left+2, ARect.Top+2, Cells[ACol, ARow]);
inherited DrawCell(ACol, ARow, ARect, AState);
end;

{----------------------------------}
{重载SelectCell处理 }
{当某一个格被选中时。处理按键值发送}
function TvirtualKeyBoard.SelectCell(ACol, ARow: Integer): Boolean;
var
KeyStr:string;
keyHex:word;
// fn:Tfun;
begin
// Fn:=Tfun.Create(self);
KeyStr:=cells[aCol,aRow];
if assigned(FVkeyDown) then OnSelectCell(self,keyStr);
if FSendHandle<>nil then
begin
if KeyStr='' then keyHex:=0 else keyHex:=ord(keystr[1]);
case AnsiIndexStr(KeyStr,[',','.','↙','←']) of
0:keyHex:=188;
1:keyHex:=VK_DECIMAL;
2:keyHex:=vk_return;//回车
3:keyHex:=VK_Back;//退格键
end;
DoBleep(500,100);
Fn.SendKey(FSendHandle.Handle,keyHex);
end;
// fn.Free;
result:=true
end;

procedure TvirtualKeyBoard.SetSendHandle(Control: TWinControl);
begin
if FSendHandle <> Control then FSendHandle := Control;
end;

{TExChart }
//==============================================================================
// TExChart:增强型的TChar组件，因为数据采集系统中老用到TChart，
//但标准的TChart功能上有点那个，HOHO,就加强加强.实际项目中用的十分方便
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//==============================================================================
procedure TExChart.DrawMouseLine(var Message: Tmessage);
var
// Fn:Tfun;
ChartIndex:integer;
MousePos:Tpoint;
begin
if FDrawMouseLineFlag then
begin
// Fn:=Tfun.Create(self);
if self.SeriesCount>0 then
begin
ChartIndex:=Fn.ChartMoveLine(self,message.LParamLo,FDrawMouseLineColor);
if (Series[0].Count>0) and (ChartIndex<>-1) then
begin
MousePos.X:=message.LParamLo;
MousePos.Y:=Message.LParamHi;
//FYLableDraw是用户表示FYLable显示的flag
if FYLableDraw then
Canvas.TextOut(3,3,FYLableCaption+FloatTostr(self.Series[0].YValue[ChartIndex])+FYLableunit);
if assigned(FChartYIndex) then
OnMouseMove(nil,ChartIndex,MousePos.X,MousePos.Y,Series[0].YValue[ChartIndex]);
end;// if (Series[0].Count>0) and (ChartIndex<>-1) then
// Fn.Free;
end;//if self.SeriesCount>0 then
end;//if FDrawMouseLineFlag then
end;
//------------------------------------------------------------------------------
procedure TExChart.SetDrawMouseLineFlag(Flag: Boolean);
begin
if FDrawMouseLineFlag<>Flag then FDrawMouseLineFlag:=Flag
end;
//------------------------------------------------------------------------------
procedure TExChart.SetDrawMouseLineColor(Color: TColor);
begin
if FDrawMouseLineColor<>Color then FDrawMouseLineColor:=Color
end;
//------------------------------------------------------------------------------
{设置用与现实Y坐标上的值得lable的名字}
procedure TExChart.SetYLableCaption(caption:String);
begin
if FYLableCaption<>caption then
FYLableCaption:=caption;
end;
//______________________________________________________________________________
procedure TExChart.SetYLableUnit(UnitValue: String);
begin
if FYLableUnit<>UnitValue then
FYLableUnit:=UnitValue;
end;
//------------------------------------------------------------------------------
procedure TExChart.SetYLableDraw(Flag: boolean);
begin
if Flag<>FYLableDraw then FYLableDraw:=Flag
end;
{-----------------------------}
{创建时的默认设置 }
{-----------------------------}
constructor TExChart.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDrawMouseLineFlag:=True;
FDrawMouseLineColor:=clBlue;
FYLableDraw:=True;
FYLableCaption:='电压:';
FYLableUnit:='(V)';
end;

{==============================================================================}
{ TExEdit}
{将回车转为Tab}
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
{===============================================================================}
constructor TExEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
LabelPosition:= lpLeft;
end;
//------------------------------------------------------------------------------
procedure TExEdit.SetCaption(const Value: string);
begin
FCaption := Value;
self.EditLabel.Caption:=FCaption;
end;
//------------------------------------------------------------------------------
procedure TExEdit.SetOnlyInputNumber(Flag: Boolean);
begin
if Flag<>FOnlyInputNumber then FOnlyInputNumber:=flag;
end;
//------------------------------------------------------------------------------
procedure TExEdit.WMKeyDown(var Message: Tmessage);
var
vKey:string;
begin
if message.WParam=VK_Return then Fn.SendKey(0,VK_TAB,vkeyClick);
//---
vkey:=copy(text,SelStart,1);//得到输入的字符
if length(text)>0 then
begin
// if (message.WParam in [$41..$5A,$61..$7A,vk_space,187..189,191,226])and FOnlyInputNumber then
// begin
(*再次过滤防止小键盘的按键被过滤*)
if (vkey[1] in ['a'..'z','A'..'Z',' ','=',',','+','-','*','/','/']) and FOnlyInputNumber then
begin
self.SelStart:=self.SelStart-1;
Fn.SendKey(self.Handle,VK_Delete);
dobleep(800,100);
end;
// end;
end;
if assigned(FKeyDown) then self.OnKeyDown(self,message.WParam);
message.Result:=0;
// Fn.Free;
end;

//------------------------------------------------------------------------------
// Tfun
//------------------------------------------------------------------------------
constructor TFun.Create(AOwner: TComponent);
begin
inherited;
SYSHintExDraw:=True;
end;
//------------------------------------------------------------------------------
procedure TFun.SetHintDraw(Flag:Boolean);
//var
// DefHint:THintWindow;
begin
SYSHintExDraw:=Flag;
if SYSHintExDraw then
HintWindowClass:=TIconHintX 把我TIconHintX设置为默认的提示栏类:
else
HintWindowClass:=THintWindow //还原为系统默认的THintWindow
end;
//------------------------------------------------------------------------------
// 得到本机的ip地址
//------------------------------------------------------------------------------
function TFun.GetLocalIP: string;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe : PHostEnt;
pptr : PaPInAddr;
Buffer : array [0..63] of char;
I : Integer;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do begin
result:=StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;
//==============================================================================
// TMyForm
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//==============================================================================
constructor TMyForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTitleNoActiveColor:=clSilver;
FTitleActiveFontColor:=clWhite;
FTitleActiveColor:=clGray;
TempTitleColor:=FTitleActiveColor;
//----
FWinRectColor:=clGray;
FWinRectLineWidth:=1;
//------
Font.Name:='宋体';
Font.Size:=9;
Font.Height:=-12;
Font.Color:=clblack;
Font.Charset:=GB2312_CHARSET;
Color:=$00E2F3F3;//默认窗体颜色
FCaption:='MyForm';
height:=150;
width:=250;
BringToFront;
SizeFlag:=false;
//ullRepaint:=false;//关闭这个选项。防止放入没焦点的组件是出错
end;
//------------------------------------------------------------------------------
procedure TMyForm.DrawTitleButton;
begin
//----关闭按钮---------
Self.ShowHint:=False;
canvas.Pen.Color:=clwhite;
canvas.Rectangle(width-20,4,width-4,20);
canvas.Font.Color:=FTitleActiveFontColor;
canvas.TextOut(width-18,6,'╳');
//----------最大化按钮------
canvas.Rectangle(width-37,4,width-21,20);
canvas.Font.Color:=FTitleActiveFontColor;
canvas.TextOut(width-35,6,'□');
//-------最小化铵钮------
canvas.Rectangle(width-54,4,width-38,20);
canvas.Font.Color:=FTitleActiveFontColor;
canvas.TextOut(width-52,6,'─');
end;
//------------------------------------------------------------------------------
procedure TMyForm.Paint;
var
// Fn:TFun;
Rect:TRect;
begin
inherited;
// Fn:=TFun.Create(self);
//标题栏范围
Rect.Left:=3;
Rect.Top:=3;
rect.Bottom:=21;
rect.Top:=3;
rect.Right:=width-3;
canvas.Brush.Color:=FTitleActiveColor;
canvas.FillRect(rect);
canvas.Rectangle(2,2,width-2,22);
DrawTitleButton;//画title按钮
//----画左和下边线
// canvas.MoveTo(width-2,2);
// canvas.LineTo(width-2,height-2);
// canvas.LineTo(2,height-2);
//---窗体标题
canvas.Font.Color:=FTitleActiveFontColor;
canvas.TextOut((width div 2) -(length(Fcaption) div 2)*5,6,Fcaption);
Fn.DrawWindowRect(handle,FWinRectColor,FWinRectLineWidth);
// Fn.Free;
end;
//------------------------------------------------------------------------------
procedure TMyForm.setAutoBringTop(const Value: Boolean);
begin
FAutoBringTop := Value;
end;

procedure TMyForm.SetCaption(str: string);
begin
if FCaption<>Str then
begin
FCaption:=Str;
Repaint;
end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetTitleActiveColor(color: TCOlor);
begin
if FTitleActiveColor<>Color then
begin
FTitleActiveColor:=Color;
TempTitleColor:=FTitleActiveColor;
Repaint;
end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetTitleActiveFontColor(Color: TColor);
begin
if FTitleActiveFontColor<>Color then
begin
FTitleActiveFontColor:=Color;
Repaint;
end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetTitleNoActiveColor(Value: TColor);
begin
FTitleNoActiveColor := Value;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetWinRectColor(color: TColor);
begin
if FwinRectColor<>color then
begin
FwinRectColor:=color;
Repaint;
end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.SetWinRectLineWidth(Lwidth: integer);
begin
if FWinRectLinewidth<>Lwidth then
begin
FWinRectLinewidth:=Lwidth;
Repaint;
end;
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMLBUTTONDBLCLK(var message: TMessage);
begin
if (message.LParamLo>1) and (message.LParamHi<20) then
begin
// if height>30 then
if SizeFlag=false then
begin
sendmessage(Handle,WM_SYSCOMMAND,SC_MaxIMIZE,0);
SizeFlag:=true;
end else
begin
sendmessage(Handle,WM_SYSCOMMAND,SC_RESTORE,0);
SizeFlag:=false;
end;
end;
//if assigned(FClick) then self.OnClick(self);
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMLMouseDown(var message: Tmessage);
var
X,Y:integer;
begin
X:=message.LParamLo;
Y:=message.LParamHi;
if assigned(FMouseDown) and(Y>23) then OnMouseDown(self,mbLeft,x,y);
// OnMouseDown(self,mbLeft,ShiftState,x,y);//重载原OnMouseDown
BringToFront; //有点击就将窗体提前
if FSizeFlag<>SZNil then ReleaseCapture;
case FSizeFlag of
SZLeft: sendmessage(Handle,wm_Syscommand,sc_size or 1,0);
SZRight:sendmessage(Handle,wm_Syscommand,sc_size or 2,0);
SZTop:sendmessage(Handle,wm_Syscommand,sc_size or 3,0);
SZBottom:sendmessage(Handle,wm_Syscommand,sc_size or 6,0);
SZLeftTop:sendmessage(Handle,wm_Syscommand,sc_size or 4,0);
SZRightTop: sendmessage(Handle,wm_Syscommand,sc_size or 5,0);
SZLeftBottom:sendmessage(Handle,wm_Syscommand,sc_size or 8,0);
SZRightBottom:sendmessage(Handle,wm_Syscommand,sc_size or 7,0);
end;
if (message.LParamLo>1) and (message.LParamHi<20) then
begin
sendmessage(Handle,wm_Syscommand,sc_Move or 2,0);
end;
//---------标题栏按钮处理-----------------
if (X<=width-4) and (X>=width-20) and
(Y<=20) and (Y>=4) then
begin
if assigned(FCLose) then OnClose(self);
Hide;
end;
//----------最大化按钮------
if (X<=width-21) and (X>=width-37) and
(Y<=20) and (Y>=4)
then begin
if SizeFlag=false then
begin
sendmessage(Handle,WM_SYSCOMMAND,SC_MaxIMIZE,0);
SizeFlag:=true;
end else
begin
sendmessage(Handle,WM_SYSCOMMAND,SC_RESTORE,0);
SizeFlag:=false;
end;
end;
//------------------
if (X<=width-38) and (X>=width-54) and
(Y<=20) and (Y>=4)
then sendmessage(handle,WM_SYSCOMMAND,SC_MINIMIZE,0);
//if assigned(FMouseDown) then self.OnMouseDown(self,mbLeft,shift,X,y);
end;
//------------------------------------------------------------------------------
procedure TMyForm.WmLMouseUp(var message: Tmessage);
begin
if assigned(FMouseUp)and(message.LParamHi>23) then onMouseUP(self,mbLeft,message.LParamLo,message.LParamHi);
if assigned(FClick)and(message.LParamHi>23) then onClick(self);//onclick事件
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMMouseEnter(var Message: TMessage);
begin
if FAutoBringTop then self.BringToFront;//用户设置是否自动提前
if assigned(FMouseEnter) then OnMouseEnter(self);
FTitleActiveColor:=TempTitleColor;
self.Repaint;
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMMouseLeave(var Message: TMessage);
begin
if assigned(FMouseleave) then OnMouseLeave(self);
FTitleActiveColor:=FTitleNoActiveColor;
self.Repaint;
end;
//-----------

procedure TMyForm.WMRMouseDown(var message: Tmessage);
begin
if assigned(FMouseDown)and(message.LParamHi>23) then OnMouseDown(self,mbRight,message.LParamLo,message.LParamHi);
end;
//----------------
procedure TMyForm.WMRMouseUp(var message: Tmessage);
begin
if assigned(FMouseUp)and(message.LParamHi>23) then OnMouseUp(self,mbRight,message.LParamLo,message.LParamHi);
end;
//------------------------------------------------------------------------------
procedure TMyForm.WMMouseMove(var message: Tmessage);
var
ShiftState:TShiftState;
X,Y:integer;
begin
X:=message.LParamLo;
Y:=message.LParamHi;
if Assigned(FMouseMove) then OnMouseMove(self,ShiftState,X,Y);
FSizeFlag:=SZNil;
cursor:=crDefault;
if ((X<Width) and (X>=Width-5)) then
begin //right调整
cursor:=crSizeWE;
FSizeFlag:=SZRight;
end;
if (X<=5) and (X>=0) then
begin //左调整
cursor:=crSizeWE;
FSizeFlag:=SZLeft;
end;
//---------------------
if (Y<=5) and (Y>=0) then
begin //上
cursor:=crSizeNS;
FSizeFlag:=SZTop;
end;
//--------
if (Y<=Height) and (Y>=Height-5) then
begin//下
cursor:=crSizeNS;
FSizeFlag:=SZBottom;
end;

//左下
if ((Y<=Height) and (Y>Height-5)) and ((X<=Width) and (X>Width-5)) then
begin
cursor:=crSizeNWSE;
FSizeFlag:=SZLeftBottom;
end;
//右下
if ((Y<=Height) and (Y>=Height-5)) and ((X<=5) and (X>=0)) then
begin
cursor:=crSizeNESW;
FSizeFlag:=SZRightBottom;
end;
//左上
if ((Y<=5) and (Y>=0)) and ((X<=5) and (X>=0)) then
begin
cursor:=crSizeNWSE;
FSizeFlag:=SZLeftTop;
end;
//右上
if ((Y<=5) and (Y>=0)) and ((X<=Width) and (X>=Width-5)) then
begin
cursor:=crSizeNESW;
FSizeFlag:=SZRightTop;
end;
//-
//---------标题栏按钮mouseMove处理-----------------
DrawTitleButton;
if (X<=width-4) and (X>=width-20) and
(Y<=20) and (Y>=4) then
begin
//----关闭按钮---------
canvas.Pen.Color:=clGray;
canvas.Rectangle(width-20,4,width-4,20);
canvas.Font.Color:=clGray;
canvas.TextOut(width-18,6,'╳');
self.Hint:='关闭';
self.ShowHint:=True;
end;
//----------最大化按钮------
if (X<=width-21) and (X>=width-37) and
(Y<=20) and (Y>=4) then
begin
//----------最大化按钮------
canvas.Pen.Color:=clGray;
canvas.Rectangle(width-37,4,width-21,20);
canvas.Font.Color:=clGray;
canvas.TextOut(width-35,6,'□');
self.Hint:='最大化';
self.ShowHint:=True;
end;

//------------------
if (X<=width-38) and (X>=width-54) and
(Y<=20) and (Y>=4) then
begin
//-------最小化铵钮------
canvas.Pen.Color:=clGray;
canvas.Rectangle(width-54,4,width-38,20);
canvas.Font.Color:=clGray;
canvas.TextOut(width-52,6,'─');
self.Hint:='最小化';
self.ShowHint:=True;
end;
end;
//------------------------------------------------------------------------------
//----------------------TFun----------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//得到CPU速度
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
function TFun.GetCPUSpeed: Double;
const
DelayTime = 500; // 时间单位是毫秒
var
TimerHi, TimerLo: DWORD;
PriorityClass, Priority: Integer;
begin
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
Sleep(10);
asm
dw 310Fh // rdtsc
mov TimerLo, eax
mov TimerHi, edx
end;
Sleep(DelayTime);
asm
dw 310Fh // rdtsc
sub eax, TimerLo
sbb edx, TimerHi
mov TimerLo, eax
mov TimerHi, edx
end;

SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result := TimerLo / (1000.0 * DelayTime);
end;
//------------------------------------------------------------------------------
// //获取CPU ID 和 CPU Vendor
//------------------------------------------------------------------------------
//获取CPU ID 和 CPU Vendor
type
TCPUID = array[1..4] of Longint;
TVendor = array [0..11] of char;
function GetCpuIDx : TCPUID; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Resukt}
MOV EAX,1
DW $A20F {CPUID Command}
STOSD {CPUID[1]}
MOV EAX,EBX
STOSD {CPUID[2]}
MOV EAX,ECX
STOSD {CPUID[3]}
MOV EAX,EDX
STOSD {CPUID[4]}
POP EDI {Restore registers}
POP EBX
end;
//--------------------------
function GetCPUVendorx : TVendor; assembler; register;
asm
PUSH EBX {Save affected register}
PUSH EDI
MOV EDI,EAX {@Result (TVendor)}
MOV EAX,0
DW $A20F {CPUID Command}
MOV EAX,EBX
XCHG EBX,ECX {save ECX result}
MOV ECX,4
@1:
STOSB
SHR EAX,8
LOOP @1
MOV EAX,EDX
MOV ECX,4
@2:
STOSB
SHR EAX,8
LOOP @2
MOV EAX,EBX
MOV ECX,4
@3:
STOSB
SHR EAX,8
LOOP @3
POP EDI {Restore registers}
POP EBX
end;
//-------------------------
(*得到CPUID*)
Function TFun.GetCPUID:string;
var
CPUID : TCPUID;
I : Integer;
begin
for I := Low(CPUID) to High(CPUID) do CPUID[I] := -1;
CPUID := GetCPUIDx;
result:= IntToStr(CPUID[1])+IntToStr(CPUID[2])+IntToStr(CPUID[3])+IntToStr(CPUID[4]);
end;
//------------------------
(*的到CPUde Vendor,也就是判断CPU是AMD的还是INTER的*)
Function TFun.GetCPUVendor: string;
begin
result := GetCPUVendorx;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//获取显示刷新率
function TFun.GetDisplayFrequency: Integer;
var
DeviceMode: TDeviceMode;
// 这个函数返回的显示刷新率是以Hz为单位的
begin
EnumDisplaySettings(nil, Cardinal(-1), DeviceMode);
Result := DeviceMode.dmDisplayFrequency;
end;

function TFun.GetDNSName(IPAddress: String): String;
begin

end;
//-------------------------------------------------------------------------------
//-------------------------
//DnsName转为IP地址
//-------------------------
function TFun.GetDNSTOIP(DNSName: String): String;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe :PHostEnt;
pptr : PaPInAddr;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
phe :=GetHostByName(pchar(DNSName));
pptr := PaPInAddr(Phe^.h_addr_list);
result:=StrPas(inet_ntoa(pptr^[0]^));
WSACleanup;
end;
//------------------------------------------------------------------------------
//-------------------------------------------------------------------------------
//-------------------------
//得到文件创建的时间
// CovFileDate获取一个文件的时间信息，配合GetFileCreateTime使用
//-------------------------
Function CovFileDate(Fd:_FileTime):TDateTime;
{ 转换文件的时间格式 }
var
Tct:_SystemTime;
Temp:_FileTime;
begin
FileTimeToLocalFileTime(Fd,Temp);
FileTimeToSystemTime(Temp,Tct);
CovFileDate:=SystemTimeToDateTime(Tct);
end;
//-------------
function TFun.GetFileCreateTime(const strFileName: string): TDateTime;
var
Tp:TSearchRec; //申明Tp为一个查找记录
begin
FindFirst(strFileName,faAnyFile,Tp); { 查找目标文件 }
FindClose(Tp);
result:=CovFileDate(Tp.FindData.ftCreationTime); //返回文件的创建时间
end;
//------------------------------------------------------------------------------
//-------------------------------------------------------------------------------
//-------------------------------------------------------------------------------
//----------------------
//获取文件最后访问日期和时间
//----------------------
function TFun.GetFileLastAccessTime(sFileName: string): TDateTime;
var
FileHandle : THandle;
LocalFileTime : TFileTime;
DosFileTime : DWORD;
FindData : TWin32FindData;
begin
result:=strToTime('1880-12-12 00:00:00');//默认出错返回;
FileHandle := FindFirstFile(PChar(sFileName), FindData);
if FileHandle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(FileHandle);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
FileTimeToDosDateTime(LocalFileTime,
LongRec(DosFileTime).Hi,LongRec(DosFileTime).Lo);
result:= FileDateToDateTime(DosFileTime);
end;
end;
end;
//------------------------------------------------------------------------------
//----------------
//获取文件修改时间
//----------------
function TFun.GetFileModifyTime(const strFileName: string): TDateTime;
var
Tp:TSearchRec; //申明Tp为一个查找记录
begin
FindFirst(strFileName,faAnyFile,Tp); { 查找目标文件 }
FindClose(Tp);
result:=CovFileDate(Tp.FindData.ftLastWriteTime);
end;

//-------------------------------------------------------------------------------
//-------------------------------------------------------------------------------
//-------------------------------------------------------------------------------
//-------------------------------------------------------------------------------
//获取第一个IDE硬盘的序列号
function TFun.GetIdeSerialNumber : string;
const IDENTIFY_BUFFER_SIZE = 512;
type
TIDERegs = packed record
bFeaturesReg : BYTE; // Used for specifying SMART "commands".
bSectorCountReg : BYTE; // IDE sector count register
bSectorNumberReg : BYTE; // IDE sector number register
bCylLowReg : BYTE; // IDE low order cylinder value
bCylHighReg : BYTE; // IDE high order cylinder value
bDriveHeadReg : BYTE; // IDE drive/head register
bCommandReg : BYTE; // Actual IDE command.
bReserved : BYTE; // reserved for future use. Must be zero.
end;
TSendCmdInParams = packed record
// Buffer size in bytes
cBufferSize : DWORD;
// Structure with drive register values.
irDriveRegs : TIDERegs;
// Physical drive number to send command to (0,1,2,3).
bDriveNumber : BYTE;
bReserved : Array[0..2] of Byte;
dwReserved : Array[0..3] of DWORD;
bBuffer : Array[0..0] of Byte; // Input buffer.
end;
TIdSector = packed record
wGenConfig : Word;
wNumCyls : Word;
wReserved : Word;
wNumHeads : Word;
wBytesPerTrack : Word;
wBytesPerSector : Word;
wSectorsPerTrack : Word;
wVendorUnique : Array[0..2] of Word;
sSerialNumber : Array[0..19] of CHAR;
wBufferType : Word;
wBufferSize : Word;
wECCSize : Word;
sFirmwareRev : Array[0..7] of Char;
sModelNumber : Array[0..39] of Char;
wMoreVendorUnique : Word;
wDoubleWordIO : Word;
wCapabilities : Word;
wReserved1 : Word;
wPIOTiming : Word;
wDMATiming : Word;
wBS : Word;
wNumCurrentCyls : Word;
wNumCurrentHeads : Word;
wNumCurrentSectorsPerTrack : Word;
ulCurrentSectorCapacity : DWORD;
wMultSectorStuff : Word;
ulTotalAddressableSectors : DWORD;
wSingleWordDMA : Word;
wMultiWordDMA : Word;
bReserved : Array[0..127] of BYTE;
end;
PIdSector = ^TIdSector;
//------------------
TDriverStatus = packed record
// 驱动器返回的错误代码，无错则返回0
bDriverError : Byte;
// IDE出错寄存器的内容，只有当bDriverError 为 SMART_IDE_ERROR 时有效
bIDEStatus : Byte;
bReserved : Array[0..1] of Byte;
dwReserved : Array[0..1] of DWORD;
end;
TSendCmdOutParams = packed record
// bBuffer的大小
cBufferSize : DWORD;
// 驱动器状态
DriverStatus : TDriverStatus;
// 用于保存从驱动器读出的数据的缓冲区，实际长度由cBufferSize决定
bBuffer : Array[0..0] of BYTE;
end;
var hDevice : THandle;
cbBytesReturned : DWORD;
// ptr : PChar;
SCIP : TSendCmdInParams;
aIdOutCmd : Array [0..(SizeOf(TSendCmdOutParams)+IDENTIFY_BUFFER_SIZE-1)-1] of Byte;
IdOutCmd : TSendCmdOutParams absolute aIdOutCmd;
//-------
(* 局部过程*)
procedure ChangeByteOrder( var Data; Size : Integer );
var
ptr : PChar;
i : Integer;
c : Char;
begin
ptr := @Data;
for i := 0 to (Size shr 1)-1 do begin
c := ptr^;
ptr^ := (ptr+1)^;
(ptr+1)^ := c;
Inc(ptr,2);
end;
end;
//---------
begin
Result := ''; // 如果出错则返回空串
if SysUtils.Win32Platform=VER_PLATFORM_WIN32_NT then begin// Windows NT, Windows 2000
// 提示! 改变名称可适用于其它驱动器，如第二个驱动器： '//./PhysicalDrive1/'
hDevice := CreateFile( '//./PhysicalDrive0', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 );
end else // Version Windows 95 OSR2, Windows 98
hDevice := CreateFile( '//./SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
if hDevice=INVALID_HANDLE_VALUE then Exit;
try
FillChar(SCIP,SizeOf(TSendCmdInParams)-1,#0);
FillChar(aIdOutCmd,SizeOf(aIdOutCmd),#0);
cbBytesReturned := 0;
// Set up data structures for IDENTIFY command.
with SCIP do begin
cBufferSize := IDENTIFY_BUFFER_SIZE;
// bDriveNumber := 0;
with irDriveRegs do begin
bSectorCountReg := 1;
bSectorNumberReg := 1;
// if Win32Platform=VER_PLATFORM_WIN32_NT then bDriveHeadReg := $A0
// else bDriveHeadReg := $A0 or ((bDriveNum and 1) shl 4);
bDriveHeadReg := $A0;
bCommandReg := $EC;
end;
end;
if not DeviceIoControl( hDevice, $0007c088, @SCIP, SizeOf(TSendCmdInParams)-1,
@aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil ) then Exit;
finally
CloseHandle(hDevice);
end;
with PIdSector(@IdOutCmd.bBuffer)^ do begin
ChangeByteOrder( sSerialNumber, SizeOf(sSerialNumber) );
(PChar(@sSerialNumber)+SizeOf(sSerialNumber))^ := #0;
Result := strpas(PChar(@sSerialNumber));
end;
end;

// 更多关于 S.M.A.R.T. ioctl 的信息可查看:
// http://www.microsoft.com/hwdev/download/respec/iocltapi.rtf

// MSDN库中也有一些简单的例子
// Windows Development -> Win32 Device Driver Kit ->
// SAMPLE: SmartApp.exe Accesses SMART stats in IDE drives

// 还可以查看 http://www.mtgroup.ru/~alexk
// IdeInfo.zip - 一个简单的使用了S.M.A.R.T. Ioctl API的Delphi应用程序

// 注意:

// WinNT/Win2000 - 你必须拥有对硬盘的读/写访问权限

// Win98
// SMARTVSD.VXD 必须安装到 /windows/system/iosubsys
// (不要忘记在复制后重新启动系统)
//-------------------------------------------------------------------------------
//-------------------------------------------------------------------------------

//打开1个URL
procedure TFun.OpenURL(URL:string);
begin
ShellExecute(0,nil,PAnsiChar(URL),nil,nil,SW_NORMAL);
end;
//------------------------------------------------------------------------------
//-----------------
//显示和隐藏系统通知区
//-----------------
procedure TFun.HideTrayNotify(sw: Boolean);
var
wnd:THandle;
begin
wnd:=Findwindow('Shell_TrayWnd',nil);
wnd:=FindwindowEx(wnd,0,'TrayNotifyWnd',nil);
if sw then
(*显示*)
showWindow(wnd,sw_Show)
else
(*隐藏*)
showWindow(wnd,sw_Hide)
end;

//------------------------------------------------------------------------------
//隐藏开始按钮
procedure TFun.HideWinButton(sw: Boolean);
var
wnd:THandle;
begin
wnd:=Findwindow('Shell_TrayWnd',nil);
wnd:=FindwindowEx(wnd,0,'Button',nil);
if sw then
(*显示*)
showWindow(wnd,sw_Show)
else
(*隐藏*)
showWindow(wnd,sw_Hide)
end;
//------------------------------------------------------------------------------
//隐藏快速启动按钮栏
procedure TFun.HideQuickLaunchBar(sw: Boolean);
var
wnd:THandle;
begin
wnd:=Findwindow('Shell_TrayWnd',nil);
wnd:=FindwindowEx(wnd,0,'ReBarWindow32',nil);
// wnd:=FindwindowEx(wnd,0,'Quick Launch',nil);
if sw then
(*显示*)
showWindow(wnd,sw_Show)
else
(*隐藏*)
showWindow(wnd,sw_Hide)
end;
//------------------------------------------------------------------------------
// HideAppInTastWin
// RegisterServiceProcess:使程序在任务管理器中隐藏
//------------------------------------------------------------------------------
//procedure TFun.HideAppInTastWin(sw: Boolean);
//begin
// if sw then
// (*显示*)
// RegisterServiceProcess(GetCurrentProcessId,0)
// else
// (*隐藏*)
// RegisterServiceProcess(GetCurrentProcessId,1)
//end;
//
//------------------------------------------------------------------------------
//得到任务栏的高度
function TFun.GetTaskBarHeight: integer;
var
Bar:TAppBarData;
begin
Bar.cbSize:=SizeOf(Bar);
ShAppBarMessage(ABM_GETTASKBARPOS,Bar);
result:=Bar.rc.Bottom-Bar.rc.Top;
end;
//------------------------------------------------------------------------------
//通过代码击活开始菜单
procedure TFun.ClickStartMenu;
begin
sendmessage(application.Handle,wm_sysCommand,Sc_TaskList,0)
end;
//------------------------------------------------------------------------------
//打开屏幕保护
procedure TFun.OpenScreenSave;
begin
sendmessage(application.Handle,wm_sysCommand,SC_SCREENSAVE,0)
end;
//------------------------------------------------------------------------------

//==============================================================================
// TFlatButton
//2004-3-29 lijinhao 23:06 (睡觉前突然想到。。。。哈哈^^)
//给panel加了mouseEnter和mouseleave，加了个边框，
//类似于office2003的安装界面里的那个选择按钮
//==============================================================================

constructor TFlatButton.Create(AOwner: TComponent);
begin
inherited create(AOwner);
FLineWidth:=1;
self.BevelOuter:=bvNone;
LineOutColor:=clGray;
//Fn.DrawWindowRect(Handle,DefLineColor,FHotLineWidth);
end;

procedure TFlatButton.WMMouseEnter(var Message: TMessage);
begin
Fn.DrawWindowRect(Handle,FLineInColor,FLineWidth);
if Assigned(FMouseEnter) then OnMouseEnter(self);

end;

procedure TFlatButton.WMMouseLeave(var Message: TMessage);
begin
Fn.DrawWindowRect(Handle,FLineOutColor,FLineWidth);
if Assigned(FMouseLeave) then OnMouseLeave(self);
// self.Color:=TempPanelColor;
// Repaint;
// Fn.DrawWindowRect(handle,self.Color);
end;

procedure TFlatButton.SetLineInColor(const Value: TColor);
begin
FLineInColor := Value;
end;

procedure TFlatButton.SetLineOutColor(const Value: TColor);
begin
FLineOutColor := Value;
end;

procedure TFlatButton.SetLineWidth(const Value: integer);
begin
FLineWidth := Value;
end;

procedure TFlatButton.Paint;
begin
inherited;
Fn.DrawWindowRect(Handle,FLineOutColor,FLineWidth);
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------

{-------------------------------------------------------------------------------
过程名: TFun.DelTree
作者: colonel
日期: 2004.03.30
参数: DirName: String
摘于KeyLife富翁笔记
-------------------------------------------------------------------------------}
//procedure TFun.DelTree(DirName: String);
// var
// hFindFile:Cardinal;
// FileName: String;
// FindFileData:WIN32_FIND_DATA;
//begin
// if DirName[Length(DirName)]<>'/' then
// DirName:= DirName + '/';
// hFindFile:= FindFirstFile(PChar(DirName + '*.*'), FindFileData);
// if hFindFile <> INVALID_HANDLE_VALUE then
// begin
// repeat
// FileName:= FindFileData.cFileName;
// if (FileName <> '.') and (FileName <> '..') then
// begin
// if (FindFileData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY) then
// DelTree(DirName + FileName)
// else
// DeleteFile(PChar(DirName + FileName));
// end;
// until FindNextFile(hFindFile, FindFileData) = false;
// Windows.FindClose(hFindFile);
// RmDir(DirName);
// end;
//end;
//------------------------------------------------------------------------------
//删除指定文件夹(含子文件夹),文件夹及其夹内文件可以具有只读或隐藏属性
//------------------------------------------------------------------------------
procedure Tfun.DeleteDir(SourcePath: String);
var
sr: TSearchRec;
begin
// Screen.Cursor:=crHourGlass;
SourcePath:=IncludeTrailingPathDelimiter(SourcePath);
if FindFirst(SourcePath + '*.*', faAnyFile , sr) = 0 then
begin
repeat
{ 如果是只读或隐藏文件则先修改其属性为一般文件才能删除 }
if ((SR.Attr and SysUtils.faReadOnly)<>0) or ((SR.Attr and faHidden)<> 0) then SetFileAttributes(Pchar(SourcePath + sr.Name),FILE_ATTRIBUTE_NORMAL);
if (sr.Attr = faDirectory + SysUtils.faReadOnly) or (sr.Attr = faDirectory + faHidden) or ((sr.Attr = faDirectory) and (sr.Name <> '.') and (sr.Name <> '..')) then
begin
{ 有下级子目录也一并删除 }
System.ChDir(sr.Name);
DeleteDir(SourcePath + sr.Name);
System.ChDir('..');
end;
Windows.DeleteFile(Pchar(SourcePath + sr.Name));
until FindNext(sr) <> 0;
Windows.FindClose(sr.FindHandle);
RemoveDir(SourcePath);
end;
// Screen.Cursor:=crDefault;
end;

//------------------------------------------------------------------------------
// 让程序运行完后就删除自己
//2004-3-30 23:20 lijinhao
//------------------------------------------------------------------------------
procedure TFun.DelSelfApp;
var
BatFile:TextFile;
begin
assignfile(BatFile,'DelTemp.bat');
rewrite(BatFile);
writeln(BatFile,':Rdel');
writeln(BatFile,'del '+ExtractFileName(application.ExeName));
writeln(BatFile,'if exist '+ExtractFileName(application.ExeName)+' goto Rdel');
writeln(BatFile,'del DelTemp.bat');
closeFile(BatFile);
ShellExecute(0,nil,'DelTemp.bat',nil,nil,SW_HIDE);
end;
//-------------------------------------------------------------------------------
//将数据转为Excel文件，TDataSet中visible为False的字段不加入
//我的好朋友: 不死鸟提供..^^...
//-------------------------------------------------------------------------------
//function TFun.DataToExcel(myExcelName: String; myDataSet: TDataSet): Boolean;
//var
// i,j,k: integer;
// S,SysPath: string;
// MsExcel:Variant;
//begin
// Result:=true;
// myExcelName:=myExcelName+'.xls';
// myDataSet.DisableControls;
// SysPath:=IncludeTrailingPathDelimiter(ExtractFilePath(Application.Exename));
// with TStringList.Create do
// try
// myDataSet.First ;
// // S:=S+Header;
// add(s);
// s:='';
// //不可见的字段不加到Excel表中
// for i:=0 to myDataSet.fieldcount-1 do
// begin
// if myDataSet.fields.visible=true then
// S:=S+#9+myDataSet.fields.DisplayLabel;
// end;
// System.Delete(s,1,1);
// Add(s);
// while not myDataSet.Eof do
// begin
// S := '';
// for i := 0 to myDataSet.FieldCount -1 do
// begin
// if myDataSet.fields.visible=true then
// S := S + #9 + myDataSet.Fields.AsString;
// end;
// System.Delete(S, 1, 1);
// Add(S);
// myDataSet.Next;
// end;
// try
// SaveToFile(SysPath+myExcelName);
// except
// // ShowMessage('写文件时发生保护性错误，Excel 如在运行，请先关闭！');
// myDataSet.EnableControls;
// Result:=false;
// exit;
// end;
// finally
// Free;
// end;
// try
// MSExcel:=CreateOleObject('Excel.Application');
// except
// // ShowMessage('Excel 没有安装，请先安装！');
// Result:=false;
// myDataSet.EnableControls;
// exit;
// end;
// try
// MSExcel.workbooks.open(SysPath+myExcelName);
// except
// // ShowMessage('打开临时文件时出错，请检查'+SysPath+myExcelName);
// myDataSet.EnableControls;
// Result:=false;
// exit;
// end;
// for k :=1 to 4 do
// MSExcel.Selection.Borders[k].LineStyle := 0;
// MSExcel.cells.select;
// MSExcel.Selection.HorizontalAlignment :=3;
// MSExcel.Selection.Borders[1].LineStyle := 0;
//
// MSExcel.Range['A1'].Select;
// MSExcel.Selection.Font.Size :=18;
//
// J:=0 ;
// for i:=0 to myDataSet.fieldcount-1 do
// if myDataSet.fields.visible then
// J:=J+1;
//
// k :=J;
// MSExcel.Range['A1:'+chr(k+64)+'1'].Select;
// MSExcel.Range['A1:'+chr(k+64)+'1'].Merge;
// MSExcel.Visible:=True;
// myDataSet.First;
// myDataSet.EnableControls;
//end;

//------------------------------------------------------------------------------
// //小写金额转大写作者:不死鸟
//呵呵..看看..银行工作的人..提供的人民币转换得也强一点..都到了亿万了.^^
//------------------------------------------------------------------------------
function TFun.ToBigRMB(RMB: string): string;
const
BigNumber = '零壹贰叁肆伍陆柒捌玖';
BigUnit = '万仟佰拾亿仟佰拾万仟佰拾元';
var
nLeft,nRigth,lTemp,rTemp,BigNumber1,BigUnit1:string;
I:Integer;
minus:boolean;
begin
try
minus:=false;
{取整数和小数部分}
if StrToFloat(rmb)<0 then
begin
RMB:=FloatToStrF(ABS(StrToFloat(RMB)),fffixed,20,2);
minus:=true;
end
else
RMB:=FloatToStrF(ABS(StrToFloat(RMB)),fffixed,20,2);

nLeft:=copy(RMB, 1, Pos('.', RMB) - 1);
nRigth:=copy(RMB, Pos('.', RMB) + 1, 2); {转换整数部分}
for I:=1 to Length(nLeft) do
begin
BigNumber1:=copy(BigNumber, StrToInt(nLeft[I]) * 2 + 1, 2);
BigUnit1:=copy(BigUnit, (Trunc(Length(BigUnit) / 2) - Length(nleft) + I - 1) * 2 + 1, 2);
if (BigNumber1='零') and ((copy(lTemp, Length(lTemp)- 1, 2))='零') then
lTemp:=copy(lTemp, 1, Length(lTemp) - 2);
if (BigNumber1='零') and ((BigUnit1='亿') or (BigUnit1='万') or (BigUnit1='元')) then
begin
BigNumber1:=BigUnit1;
if BigUnit1<>'元' then
BigUnit1:='零'
else
BigUnit1:='';
end;
if (BigNumber1='零') and (BigUnit1<>'亿') and (BigUnit1<>'万') and (BigUnit1<>'元') then BigUnit1:='';
lTemp:=lTemp + BigNumber1 + BigUnit1;
end;
if trim(ltemp)='元' then ltemp:='零'+ltemp;

if Pos('亿万', lTemp)<>0 then Delete(lTemp, Pos('亿万', lTemp) + 2, 2); {转换小数部分}

if (trim(copy(ltemp,length(ltemp)-3,2))<>'')and(pos(copy(ltemp,length(ltemp)-3,2),bigunit)>0)and(StrToInt(nRigth[1])<>0 or StrToInt(nRigth[2])) then ltemp:=ltemp+'零';

if (trim(ltemp)='零元')and(StrToInt(nRigth[1])<>0 or StrToInt(nRigth[2])) then ltemp:='';

if minus then ltemp:='(负)'+ltemp;

if StrToInt(nRigth[1])<>0 then rTemp:=copy(BigNumber, StrToInt(nRigth[1]) * 2 + 1, 2) + '角';

if StrToInt(nRigth[2])<>0 then
begin
if (StrToInt(nRigth[1])=0)and((rightstr(ltemp,2)<>'零')and(trim(rightstr(ltemp,2))<>'')) then rTemp:='零';
rTemp:=rTemp + copy(BigNumber, StrToInt(nRigth[2]) * 2 + 1, 2) + '分';
Result:='(人民币):'+lTemp + rTemp;
end
else
Result:='(人民币):'+lTemp + rTemp + '整';
except
Result:='非法数据';
end;
end;
{-------------------------------------------------------------------------------}
//输入的日期是否正确
//作者:不死鸟
function TFun.IsRightDate(mInputDate: String): Boolean;
begin
try
StrToDate(mInputDate);
Result:=True;
except
Result:=False;
end;
end;
{-------------------------------------------------------------------------------}
//作者:不死鸟
//字符串加密、解密函数 key=1时为加密，0为解密
function TFun.Decrypt(const s: string; key:byte): string;
var
I:Integer;
begin
Result:='';
case key of
1: //加密
begin
for i:=1 to length(s) do
result := result+chr(ord(s) xor i xor 69);
result := result + char(69);
end;
0: //解密
begin
for i:=1 to length(s) - 1 do
result := result+chr(ord(s) xor i xor 69);
end;
end;
end;
//------------------------------------------------------------------------------
//哈哈..小鸟对原有rigthStr的修正，不错哈哈。。起先我还以为贺rightstr一样打算不加的
// RightCopy('abcdefghijklmnopq',2,5),返回lmnop
// Rightstr('abcdefghijklmnopq',2,5);返回op
//--------------------------------------------------------
function TFun.RightCopy(S: string; Index, count: Integer): string;
begin
RightCopy := copy(S,Length(S)-count+1-(Index-1),count);
end;
//-------------------------------------------------------------------------------
//lijinjie
//2004-4-4号..采用csv格式..将数据转换为excel.
//速度非常快,
//避免了用comobj带来到弊端
//GroupCount:用于设定分栏数。。默认为1
//ShowCompleteBoX:boolean;来设定完成是否显示完成提示
//-------------------------------------------------------------------------------
procedure TFun.DataToExcelCSV(SaveFileName:string;DataSet:TDataSet;ShowCompleteBoX:Boolean;GroupCount:integer);
Function CheckStr(str:string):string;
begin
if IsStrInOtherStr(str,',') then str:='"'+str+'"';
result:=str;
end;
//===============//
var
ExcelFile:TextFile;
iRecordCount:integer;//记录数
iFieldCount:integer;//字段数
i,j,k:integer;
TempStr:string;
begin
try
if Not DataSet.Active then DataSet.Open;
iRecordCount:=DataSet.RecordCount;
iFieldCount:=DataSet.FieldCount;
assignFile(ExcelFile,SaveFileName+'.csv');
rewrite(ExcelFile);
DataSet.First;
(*--------写字段头------*)
TempStr:='';
for K:=0 to iFieldCount-1 do //字段数
begin
if TempStr<>'' then
TempStr:=TempStr+','+CheckStr(DataSet.Fields[k].FieldName)
else
TempStr:=CheckStr(DataSet.Fields[k].FieldName)
end;(* for K:=1 to FieldCount do*)
for i:= 1 to GroupCount-1 do TempStr:=TempStr+','+TempStr;
writeLn(ExcelFile,TempStr);
//---------------------------------
(*写入记录，按分栏数来写*)
for i:=1 to round(iRecordCount div GroupCount)+1 do
begin
TempStr:='';
//如:F0 F1 F2 F3 | F0 F1 F2 F3
for j:=1 to GroupCount do //分栏数
begin
if DataSet.Eof then break;
// inc(i);
for K:=0 to iFieldCount-1 do //字段数
begin
//--------------
if tempstr<>'' then
TempStr:=TempStr+','+CheckStr(DataSet.Fields[k].AsString)
else
TempStr:=CheckStr(DataSet.Fields[k].AsString);
//------------
end;(* for K:=1 to FieldCount do*)
DataSet.Next;
end;(* for j:=1 to GroupCount do*)
writeLn(ExcelFile,TempStr);
if DataSet.Eof then break;
end;//while i<=round(iRecordCount div GroupCount) do
if ShowCompleteBoX then MessageBox(0,'完成DataToExcel的转换！','完成提示:',mb_ok+MB_IconInformation)
finally
closeFile(ExcelFile);
end;
end;

function TFun.IntToHexEx(sInt:word; const Bit:integer): string;
begin
result:=BitToHex(IntToBit(sInt),Bit)
end;

{ TSwithButton }

procedure TSwithButton.Click;
begin
inherited click;
if FswithFlag then
begin
PCaption:=Caption;//保存原来的caption值
Caption:=FCaptionSwith;
FswithFlag:=false;
end else
begin
Caption:=PCaption;
FswithFlag:=true;
end;
if assigned(FOnClick) then FOnClick(self,FswithFlag);
end;

constructor TSwithButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSwithFlag:=True;
end;

initialization
InitSysType;
//if SYSHintExDraw then HintWindowClass:=TIconHintX; 把我TIconHintX设置为默认的提示栏类:
// if DebugHook=1 then application.MessageBox('Hello','222',16)
{code}
finalization
{code}

end.

yangar9179

关注

0
点赞
踩
3

收藏

觉得还不错? 一键收藏
0
评论
DELPHI常用的函数库

http://www.smatrix.org/bbs/simple/index.php?t2328.htmlunit myFun;{-----------------------------------}{ Create by 李金浩 }{ QQ:67260745 }{ 2004-3-21 }{ 我的目标-
复制链接

扫一扫