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;
| ||||||