myfun.pas

西门子Prodave6.0 的Delphi 版本, 需要安装 Prodave60软件,支持以太网通讯

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, 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}

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

{==============================================================================}
// 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进行继承
//==============================================================================

//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
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,TMyForm])