常用函数、过程汇总

得到Access97的密码：
function GetAccessPassword(FilePath:string):string;
const
     xorString:array[0..12]of byte=
      ( $86, $FB, $EC, $37,
        $5D, $44, $9C, $FA,
        $C6, $5E, $28, $E6,$13 );
var
    passBuf:array[0..14]of byte;
    pass:array[0..14]of char;
    resultPass:string;
    B:Byte;
    F:TFileStream;
    i:integer;
begin
    F:=TFileStream.Create(FilePath,fmShareDenyNone);
    //office 97
    try
       F.Seek($42,soFromBeginning);
       F.Read(passBuf,14);
       for I:=0 to 13 do
       begin
           B := passBuf[i] xor xorString[i];
           pass[i]:=char(B);
       end;
       pass[sizeof(pass) - 1] := #0;
       resultPass:=StrPas(Pass);
    finally
         F.Free;
    end;
    result:=resultPass;
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

过滤string
如：str:='aa,dd,dd,cc,,jjj'
那么str:=GetMaskString(str,',',1);
   str将会等于'aa';
类推。

function GetMaskString(S,Mask:string;Position:integer):string;
var Str:string;
    i,Len:integer;
begin
  Str:='';
  for i:=0 to Position -1 do
  begin
    if (Pos(Mask,S)<=0) then //最后
    begin
      Str:=S;
      Break;
    end;
    Str:=Copy(S,1,Pos(Mask,S)-1);
    Len:=Length(Str);
    S:=Copy(S,Len+2,Length(S)-Len-1);
  end;
  Result:=Str;
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

uses FileCtrl,stdCtrl;

//得到Dir目录中，mask条件（*.exe;*.mdb)的文件，存放到List
Procedure GetDirectoryFile(Owner:TForm;List:TStrings;Dir,Mask:string);
var File1:TFileListBox;
    i:integer;
begin
    file1:=TFileListBox.Create(Owner);
    file1.Parent :=Owner;
    file1.Mask:=Mask;
    file1.Visible :=false;
    file1.Directory :=dir;
    list.BeginUpdate;
    list.Clear;
    for i:=0 to file1.Items.Count-1 do
        list.Add(file1.Items[i]);
    list.EndUpdate;
    file1.free;
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

//将系统加入到托盘，像金山词霸那样。
procedure AddIcon(bAdd:boolean;selfHandle:THandle;msg:UINT;tip:string);
var
  FIconData: TNotifyIconData;
begin
  with FIconData do
    begin
      cbSize := SizeOf(FIconData);
      Wnd := selfHandle;
      uID := $DEDB;
      uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
      hIcon := application.Icon.Handle;
      uCallbackMessage := msg;
      StrCopy(szTip, PChar(tip));
    end;
  if bAdd then
     Shell_NotifyIcon(NIM_Add, @FIconData)
  else
     Shell_notifyIcon(NIM_Delete,@FiconData);
end;
//如果不想显示出窗体。
{
procedure TForm1.OnCreate(Sender as TObject);
begin
  Application.ShowMainForm:=false;
  AddIcon(true,self,WM_myCallbackMSG,'my hint');
  ShowWindow(Handle,SW_HIDE);
end;
}

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

关于建立一个tip的提示窗体：

var
  TipForm:TForm;
  TipLabel:TLabel;

procedure FreeTipDialog;
begin
  if TipForm<>nil then
    TipForm.Close;
end;

procedure MyClose(Sender :TObject;var Action:TCloseAction);
begin
  TipForm:=nil;
  Action:=caFree;
end;

procedure CreateTipDialog(Tip:string);
begin
  if TipForm=nil then
  begin
    TipForm:=TForm.Create(Application);
    with TipForm do
    begin
      OnClose:=MyClose;
      BorderIcons:=[];
      FormStyle:=fsStayOnTop;
      BorderStyle:=bsSizeToolWin;
      Font.Size :=10;
      Font.Name :='宋体';
      Position:=poScreenCenter;
      ClientWidth:=350;
      ClientHeight:=80;
    end;
    TipLabel:=TLabel.Create(TipForm);
    with TipLabel do
    begin
      Name:='Message';
      Parent:=TipForm;
      AutoSize:=true;
      WordWrap:=True;
      Caption:=Tip;
      SetBounds(20,30,300,32);
    end;
    TipForm.Show;
    TipForm.Update;
  end;
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

读取IE收藏夹内网址的信息

procedure TForm1.ToolButton1Click(Sender: TObject);
label
 Write;
var
 Favorites:String;
 Search:TSearchRec;
begin
 Favorites:=GetFavoritesPath;
 if Favorites='' then
   begin
    MessageBox(Handle,'访问收藏夹主键错误！','提示信息',MB_OK);
    exit;
   end;
 Memo1.Clear;
 with Search,Memo1.Lines do
 begin
  if FindFirst(Favorites+'*.url',0,Search)=0 then
   begin
    Write:
    Add(GetFavoritesUrl(Favorites+Name));
    SetLength(Name,Length(Name)-4);
    Add(Name);
    if FindNext(Search)=0 then
      goto Write;
   end;
 end;
end;

function TForm1.GetFavoritesPath:String;
var
 reg:TRegistry;
begin
 Result:='';
 reg:=TRegistry.Create;
 with reg do
 begin
  RootKey:=HKEY_USERS;
  if OpenKey('.DEFAULT/Software/Microsoft/Windows/CurrentVersion/Explorer/User Shell Folders',false)=true then
    Result:=ReadString('Favorites')+'/';
  CloseKey;
  Free;
 end;
end;

{function TForm1.GetFavoritesUrl(FavoritesFile: String): String;
begin
 with TIniFile.Create(FavoritesFile)do
 begin
  Result:=ReadString('InternetShortcut','URL','');
  Free;
 end;
end;}

function TForm1.GetFavoritesUrl(FavoritesFile: String): String;
var
 i:integer;
begin
 Result:='';
 with TStringList.Create do
 begin
  LoadFromFile(FavoritesFile);
  i:=IndexOf('[InternetShortcut]');
  if i=-1 then
    exit;
  Result:=Strings[i+1];
  System.Delete(Result,1,4);
  Free;
 end;
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

位图的淡入

  在form1上放入Image1、Button1,装入bmp位图,设置Autosize:=true,在Button1的Click编写如下事件:
procedure TForm1.Button1Click(Sender: TObject);
var
x,y,i: integer;
ptr : PByteArray;
begin
    image1.Picture.Bitmap.PixelFormat:=pf24bit;
    for i := 1 to 255 do
    begin
        for y := 0 to image1.Height - 1 do
        begin
            ptr := image1.Picture.Bitmap.ScanLine[y];
            for x := 0 to ((image1.Width *3) - 1) do
            begin
                if i<126 then
                begin
                    if ptr[x] > 1 then ptr[x] := ptr[x] - 2;//2用来调整速度
                end
                else  //后部分加快速度
                if ptr[x] > 9 then ptr[x] := (ptr[x] - 10);
            end;

        end;

        Canvas.Draw(0,0,image1.Picture.Bitmap);
        Application.ProcessMessages;
    end;

end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

一个利用系统时间产生随机数的程序,比系统的随机函数真实
function Myrandom(Num: Integer): integer;
var
  T: _SystemTime;
  X: integer;
  I: integer;
begin
  Result := 0;
  GetSystemTime(T);
  X := T.wDayOfWeek * T.wYear * T.wMilliseconds*T.wSecond * (random(Num)+1) + Random(1);
  if X < 0 then X := -X;
  X := Random(X);
  if(num = 0) then Exit;
  X := X mod num;
  for I := 0 to X do            //通过随机发生次数来控制产生不同的随机数
    X := Random(Num);
  Result := X;
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
bmp2wmf

procedure BmpToWmf (BmpFile,WmfFile:string);  
var  
  MetaFile : TMetaFile;  
  MFCanvas : TMetaFileCanvas;  
  BMP : TBitmap;  
begin  
  {Create temps}  
  MetaFile := TMetaFile.Create;  
  BMP := TBitmap.create;  
  BMP.LoadFromFile(BmpFile);  
  {Igualemos tama駉s}  
  {Equalizing sizes}  
  MetaFile.Height := BMP.Height;  
  MetaFile.Width := BMP.Width;  
  {Create a canvas for the Metafile}  
  MFCanvas:=TMetafileCanvas.Create(MetaFile, 0);  
  with MFCanvas do  
  begin  
  {Draw the BMP into canvas}  
  Draw(0, 0, BMP);  
  {Free the Canvas}  
  Free;  
  end;  
  {Free the BMP}  
  BMP.Free;  
  with MetaFile do  
  begin  
  {Save the Metafile}  
  SaveToFile(WmfFile);  
   {Free it...}  
  Free;  
  end;  
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
BMP2JPG

uses jpeg;  

procedure TForm1.Button1Click(Sender: TObject);  
var  
  bmp : TImage;  
  jpg : TJpegImage;  
begin  
  bmp := TImage.Create(nil);  
  jpg := TJpegImage.Create;  
  bmp.picture.bitmap.LoadFromFile ( 'c:/picture.bmp' );  
  jpg.Assign( bmp.picture.bitmap );  
  // Here you can set the jpg object's properties as compression, size and more  
  jpg.SaveToFile ( 'c:/picture.jpg' );  
  jpg.Free;  
  bmp.Free;  
end;

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
建立临时表

1.建立临时表
　　数据输入是开发数据库程序的必然环节。在Client/Server结构中，客户端可能要输入一批数据后，再向服务器的后台数据库提交，这就需要在本地（客户端）建立临时数据表来存储用户输入的数据，待提交后，清除本地表数据。这种方法的好处是：提高输入效率，减小网络负担。

　　由于用户一次输入的数据量一般情况下较小（不会超过几百条记录），所以临时表可以建立在内存中，这样处理速度较快。
　　方法1：使用查询控件(TQuery)
　　第1步：在窗体上放上查询控件(TQuery)，设置好所连接的数据表。
　　第2步：使TQuery. CachedUpdates=True;
      　　 TQuery. RequestLive=True
　　第3步：在原有的SQL语句后加入一条Where子语句，要求加入这条Where子语句后SQL查询结果为空。
　　例如：
   　　SELECT Biolife.″Species No″, Category, Common_Name, Biolife.″Species Name″, Biolife.″Length (cm)″, Length_In, Notes, Graphic
　     　FROM ″biolife.db″ Biolife
     　　where Biolife.Category=′A′ and Biolife.Category=′B′
　　这样临时表就建立完成了。

　　方法2：使用代码创建临时表
　　代码如下：
　　function CreateTableInMemory(const AFieldDefs:TFieldDefs):TDataSet;
　　var
           TempTable:TClientDataSet;
　　begin
　　 TempTable:=nil;
　　 Result:=nil;
　　 if AFieldDefs<>nil then
　　 begin
  　　 try
    　　 TempTable:=TClientDataSet.Create(Application);
    　　 TempTable.FieldDefs.Assign(AFieldDefs);
    　　 TempTable.CreateDataSet;
    　　 Result:=(TempTable as TDataSet);
  　　 Except
    　　 if TempTable<>nil then
                     TempTable.Free;

     　  Result:=nil;
    　　 raise;
　  　 end
    end
　end;

　　在程序中按如下方法使用：
　　procedure TForm1.Button1Click(Sender: TObject);
　　var
           ADataSet:TDataSet;
　　begin
　　 ADataSet:=TDataSet.Create(Self);
　　 with ADataSet.FieldDefs do
　　 begin
   　　 Add(′Name′,ftString,30,False);
   　　 Add(′Value′,ftInteger,0,False);
　　 end;

　　 with DataSource1 do
　　 begin
   　　 DataSet:=CreateTableInMemory(ADataSet.FieldDefs);
   　　 DataSet.Open;
　　 end;

　　 ADataSet.Free;
　　end;

　　临时表创建完成。

　　方法1使用简单，但由于利用查询控件，清空数据时需要查询服务器后台数据库，所以速度稍慢，而且不适用于临时表中各个字段由数个数据表的字段拼凑而成的情况。方法2适用范围广、速度快，但需要编写代码。（代码中TFieldDefs的使用方法十分简单，见Delphi的联机帮助）。

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
从内存中卸载DLL
function KillDll(aDllName: string): Boolean;
var
hDLL: THandle;
aName: array[0..10] of char;
FoundDLL: Boolean;
begin
  StrPCopy(aName, aDllName);
  FoundDLL := False;
  repeat
  hDLL := GetModuleHandle(aName);
  if hDLL = 0 then
  Break;
  FoundDLL := True;
  FreeLibrary(hDLL);
  until False;
 
  if FoundDLL then
  MessageDlg('Success!', mtInformation, [mbOK], 0)
  else
  MessageDlg('DLL not found!', mtInformation, [mbOK], 0);
end;



待续……



2005-5-18 17:29:56    
 发表评语&raquo;&raquo;&raquo;    

 2005-5-31 13:22:34    在流中查找任意字串function ScanStream(T:Tstream;S:String):integer;
var
  i,j:integer;
  p:Pchar;
begin
  getMem(p,T.size);//分配内存
  T.ReadBuffer(p^,t.Size );//读

  for i:=0 to T.Size -1 do
  begin
    for j:=1 to length(S) do
      if p[i+j]<>S[j] then break;//有一个不同即退出
    if j>length(S) then
    begin //依据
      result:=i+1;
      break; //完成
    end;
  end;
  FreeMem(p);
end;

 
 2005-6-1 15:14:49    屏蔽 任务管理器，EXPLORER.EXE，alt_Tab，alt_f4今天在浏览帖子时发现一位大侠的代码：
procedure TMainForm.FormCreate(Sender: TObject);
begin
 //屏蔽alt_f4键
  HotKeyId := GlobalAddAtom('HotKey') - $C000;
  RegisterHotKey(Handle, hotkeyid, Mod_Alt,vk_f4);
 //屏蔽alt_Tab键
  HotKeyId := GlobalAddAtom('HotKey1') - $C000;
  RegisterHotKey(Handle, hotkeyid, Mod_Alt,vk_tab);
end;

//
//12.终止某一正在运行的进程
//
procedure HideProcess(ProcessName:string);
var h:Thandle;
    a:Dword;
    p:ProcessInfo;
    i:integer;
    Current:TList;
begin
  ProcessList(current);
  for i:=0 to current.Count-1 do
  begin
    p:=Current.Items[i];
    if ansiuppercase(p.ExeFile)=ansiuppercase(ProcessName) then
    begin
      h:=OpenProcess(Process_All_Access,true,p.ProcessID);
      GetExitCodeProcess(h,a);
      TerminateProcess(h,a);
    end;
  end;
end;

在一个时间空间里写上
    //关闭EXPLORER.EXE
    HideProcess('EXPLORER.EXE');
    HideProcess('explorer.exe');

    //屏蔽任务管理器
    HideProcess('TASKMGR.EXE');
    HideProcess('taskmgr.exe');
最后把你的程序的名称写在注册表的
HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Winlogon
Shell 项的下
注意要这么写 EXPLORER.exe,你的程序.exe

原帖：
http://www.delphibbs.com/delphibbs/dispq.asp?lid=3090448

 
 2005-6-3 9:01:26    怎样得到CPU的序列号unit Main;

interface

uses  Windows,  Messages,  SysUtils,  Classes,  Graphics,  Controls,
Forms,  Dialogs,  ExtCtrls,  StdCtrls,  Buttons;

type
TDemoForm = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
GetButton: TBitBtn;
CloseButton: TBitBtn;
Bevel1: TBevel;
Label5: TLabel;
FLabel: TLabel;
MLabel: TLabel;
PLabel: TLabel;
SLabel: TLabel;
PValue: TLabel;
FValue: TLabel;
MValue: TLabel;
SValue: TLabel;
procedure GetButtonClick(Sender: TObject);
end;

var
DemoForm: TDemoForm;

implementation

{$R *.DFM}

const
ID_BIT = $200000;   // EFLAGS ID bit
type
TCPUID = array[1..4] of Longint;
TVendor = array [0..11] of char;

function IsCPUID_Available : Boolean; register;
asm
PUSHFD       {direct access to flags no possible, only via stack}
POP     EAX     {flags to EAX}
MOV     EDX,EAX   {save current flags}
XOR     EAX,ID_BIT {not ID bit}
PUSH    EAX     {onto stack}
POPFD        {from stack to flags, with not ID bit}
PUSHFD       {back to stack}
POP     EAX     {get back to EAX}
XOR     EAX,EDX   {check if ID bit affected}
JZ      @exit    {no, CPUID not availavle}
MOV     AL,True   {Result=True}
@exit:
end;

function GetCPUID : 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 GetCPUVendor : 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;

procedure TDemoForm.GetButtonClick(Sender: TObject);
var
CPUID : TCPUID;
I     : Integer;
S   : TVendor;
begin
  for I := Low(CPUID) to High(CPUID)  do CPUID[I] := -1;
  if IsCPUID_Available then begin
    CPUID := GetCPUID;
    Label1.Caption := 'CPUID[1] = ' + IntToHex(CPUID[1],8);
    Label2.Caption := 'CPUID[2] = ' + IntToHex(CPUID[2],8);
    Label3.Caption := 'CPUID[3] = ' + IntToHex(CPUID[3],8);
    Label4.Caption := 'CPUID[4] = ' + IntToHex(CPUID[4],8);
    PValue.Caption := IntToStr(CPUID[1] shr 12 and 3);
    FValue.Caption := IntToStr(CPUID[1] shr 8 and $f);
    MValue.Caption := IntToStr(CPUID[1] shr 4 and $f);
    SValue.Caption := IntToStr(CPUID[1] and $f);
    S := GetCPUVendor;
    Label5.Caption := 'Vendor: ' + S; end
  else begin
    Label5.Caption := 'CPUID not available';
  end;
end;

end.

 
 2005-6-3 9:02:23    如何取得CPU的运行速度unit UCPUSpd;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, StdCtrls, Buttons;

type
TFormCPUSpeed = class(TForm)
PageControl: TPageControl;
BitBtnStart: TBitBtn;
BitBtnStop: TBitBtn;
TabSheet: TTabSheet;
LabelCPUSpeed: TLabel;
LabelInfo: TLabel;
LabelWeb: TLabel;
procedure BitBtnStartClick(Sender: TObject);
procedure BitBtnStopClick(Sender: TObject);
private
{ Private declarations }
Stop: Boolean;
public
{ Public declarations }
end;

var
FormCPUSpeed: TFormCPUSpeed;

implementation

{$R *.DFM}

function GetCPUSpeed: Double;
const
DelayTime = 500; // measure time in ms
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;

procedure TFormCPUSpeed.BitBtnStartClick(Sender: TObject);
begin
  BitBtnStart.Enabled := False;
  BitBtnStop.Enabled := True;
 
  Stop := False;
  while not Stop do
  begin
    LabelCPUSpeed.Caption := Format('CPU speed: %f MHz', [GetCPUSpeed]);
    Application.ProcessMessages;
  end;
 
  BitBtnStart.Enabled := True;
  BitBtnStop.Enabled := False;
end;

procedure TFormCPUSpeed.BitBtnStopClick(Sender: TObject);
begin
  Stop := True;
end;

end.

 
 2005-6-3 9:03:26    给自己的文件类型添加ShellNew功能// 设置某一扩展名的文件可以在右键菜单中用“新建”命令创建

procedure RegisterShellNew(Prefix:String);
var
reg:TRegistry;
begin
  reg:=TRegistry.Create;
  reg.RootKey:=HKEY_CLASSES_ROOT;
  reg.OpenKey('.'+prefix+'/ShellNew',True);
  reg.WriteString('NullFile', '');
  reg.CloseKey;
  reg.free;
end;

 
 2005-6-3 16:56:54    遍历指定目录下的所有文件procedure FindFiles(APath, AFile: string;Strings1:Tstrings);
var
  FindResult: integer;
  FSearchRec, DSearchRec: TSearchRec;
  function IsDirNotation(ADirName: string): Boolean;
  begin
    Result := ((ADirName = '.') or (ADirName = '..'));
  end;
begin
  if APath[Length(APath)] <> '/' then
    APath := APath + '/';
  FindResult := FindFirst(APath + AFile, faAnyFile + faHidden +faSysFile + faReadOnly, FSearchRec); //在根目录中查找指定文件
  try
    while FindResult = 0 do
    begin
      Strings1.Add(APath + FSearchRec.Name);
      FindResult := FindNext(FSearchRec); // 查找下一个指定文件
    end;
    FindResult := FindFirst(APath + '*.*', faDirectory, DSearchRec);  //进入当前目录的子目录继续查找
    while FindResult = 0 do
    begin
      if ((DSearchRec.Attr and faDirectory) = faDirectory) and not IsDirNotation(DSearchRec.Name) then
        FindFiles(APath + DSearchRec.Name, AFile,Strings1);   //递归调用FindFiles函数
      FindResult := FindNext(DSearchRec);
    end;
  finally
    FindClose(FSearchRec);
  end;
end;  

 
 2005-6-6 9:48:53    打造Delphi中字符串的replace函数注：其实Delphi的StringReplace函数就是专为满足这个需要而设的。
procedure replace(var s:string;const SourceChar:pchar;const RChar:pchar);
//第一个参数是原串，第二个是模式串，第三个是替换串
var
  ta,i,j:integer;
  m,n,pn,sn:integer;
  {SLen表示原串的长度，SCLen表示模式传的长度，RCLen表示替换串的长度}
  SLen,SCLen,RCLen:integer;
  IsSame:integer;
  {用来保存替换后的字符数组}
  newp:array of char;
begin
  SLen:=strlen(pchar(s));
  SCLen:=strlen(SourceChar);
  RCLen:=strlen(RChar);
 
  j:=pos(string(SourceChar),s);
  s:=s+chr(0);
  ta:=0;
  i:=j;
 
  while s[i]<>chr(0) do   //这个循环用ta统计模式串在原串中出现的次数
  begin
    n:=0;
    IsSame:=1;
    for m:=i to i+SCLen-1 do
    begin
      if m>SLen then
      begin
        IsSame:=0;
        break;
      end;
      if s[m]<>sourceChar[n] then
      begin
        IsSame:=0;
        break;
      end;
      n:=n+1;
    end;
    if IsSame=1 then
    begin
      ta:=ta+1;
      i:=m;
    end
    else
      i:=i+1;
  end;

  if j>0 then
  begin
    pn:=0;sn:=1;
    //分配newp的长度，+1表示后面还有一个#0结束符
    setlength(newp,SLen-ta*SCLen+ta*RCLen+1);
    while s[sn]<>chr(0) do //主要循环，开始替换
    begin
      n:=0;IsSame:=1;
      for m:=sn to sn+SCLen-1 do //比较子串是否和模式串相同
      begin
        if m>SLen then begin IsSame:=0;break; end;
        if s[m]<>sourceChar[n] then begin IsSame:=0;break; end;
        n:=n+1;
      end;
   
    if IsSame=1 then//相同
    begin
      for m:=0 to RCLen-1 do
      begin
        newp[pn]:=RChar[m];pn:=pn+1;
      end;
      sn:=sn+SCLen;
    end
    else
    begin //不同
      newp[pn]:=s[sn];
      pn:=pn+1;sn:=sn+1;
    end;
  end;

  newp[pn]:=#0;
  s:=string(newp); //重置s，替换完成！
end;

end;

 
 2005-6-6 15:56:34    [Delphi]XP下屏蔽win键 //winxp下屏蔽win键的dll,调用BeginHook和EndHook就可以了.
library HookDLL;
uses
  Windows, SysUtils, Messages;

var
  KeyHook: HHook;

function HookKey(Code: integer; wParam: wParam; lParam: lParam): LRESULT; stdcall;
type
  PKBDLLHOOKSTRUCT = ^KBDLLHOOKSTRUCT;
  KBDLLHOOKSTRUCT = record
    vkCode: DWORD;
    ScanCode: DWORD;
    Flags: DWORD;
    Time: DWORD;
    dwExtraInfo: DWORD;
  end;
begin
  //屏蔽win键
  if (Code = HC_ACTION) and ((PKBDLLHOOKSTRUCT(lParam).vkCode = VK_LWIN)
    or (PKBDLLHOOKSTRUCT(lParam).vkCode = VK_RWIN)) then begin
    Result := 1
  end
  else
    Result := CallNextHookEx(KeyHook, Code, wParam, lParam);
end;

procedure BeginHook;
begin
  KeyHook := SetWindowsHookEx(13{=WH_KEYBOARD_LL}, @HookKey, HInstance, 0);
end;

procedure EndHook;
begin
  UnhookWindowsHookEx(KeyHook);
end;

exports
  BeginHook, EndHook;

begin

end.


//exe调用例子
unit FrmExe;

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, Buttons;

type
  TForm1 = class(TForm)
    btn1: TButton;
    btn2: TButton;
    procedure btn1Click(Sender: TObject);
    procedure btn2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private

  public

  end;

var
  Form1: TForm1;

procedure  BeginHook;  external 'HookDLL.dll';
procedure  EndHook;  external 'HookDLL.dll';

implementation

{$R *.dfm}
procedure TForm1.btn1Click(Sender: TObject);
begin
  BeginHook;
end;

procedure TForm1.btn2Click(Sender: TObject);
begin
  EndHook;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  EndHook;
end;

end.

 
 2005-6-8 10:53:52    整理Access数据库，使之更小数据库不带密码的：
function CompactAndRepair(const OldMDB: string; const NewMDB : string) : Boolean;
const
  sProvider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
var
  oJetEng : JetEngine;
  TmpMDB: string;
begin
  TmpMDB := NewMDB;
  if OldMDB = NewMDB then
    TmpMDB := ExtractFilePath(NewMDB) +
              IntToStr(GetTickCount) + '-' + IntToStr(GetCurrentThreadID) + '.mdb';
             
  try
    oJetEng := CoJetEngine.Create;
    oJetEng.CompactDatabase(sProvider + 'Data Source=' + OldMDB,
                            sProvider + 'Data Source=' + TmpMDB);
    oJetEng := nil;

    if TmpMDB <> NewMDB then
    begin
      DeleteFile(NewMDB);
      RenameFile(TmpMDB, NewMDB);
    end;

    Result  := True;
  except
    oJetEng := nil;
    Result := False;
  end;
end;

另外再通过 Project / Import type library 菜单将MSJRO.DLL和msado15.dll这两个文件导入生成单元文件JRO_TLB.PAS和ADODB_TLB.pas这两个单元文件，在程序中包含这两个单元就行了！